时间戳

首页 > 解决方案 > 合并来自具有不同标题和标题行号的多个 Excel 工作表的工作表

excel - 合并来自具有不同标题和标题行号的多个 Excel 工作表的工作表

问题描述

您好，我正在尝试将来自不同来源的多个工作表 (15) 组合成一个带有标准化标题的 Excel 工作表。困难的部分是：

  1. 对于跨工作表的相同变量，每个工作表可能具有不同的标题名称
  2. 每个工作表中标题的起始行不同
  3. 需要为从该工作表引入的每一行添加数据选项卡源的标识符

我创建了一个我计划尝试用于循环的密钥。键包含“最终标题”，对于每个示例表，在最终标题下包含特定选项卡标题的名称。此外，它还包括标题起始行号。

每个选项卡的标题键和标题行号

我对 VBA 很陌生，老实说，我什至在努力开始这一点，所以非常感谢可以提供的任何支持。

标签： excelvbamerge

解决方案

使用键创建摘要

Option Explicit

Sub createSummary()
    
    Const kName As String = "KeySheet"
    Const kFirst As String = "A1"
    Const rName As String = "Summary"
    Const rFirst As String = "A1"
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Write values from Key Range to Key Data array.
    With wb.Worksheets(kName)
        Dim kData As Variant ' Key Data
        kData = getRange(defineRangeUsingFirstCell(.Range(kFirst)))
    End With
    
    ' Write values from worksheet ranges to Worksheet Data array.
    Dim kRows As Long
    kRows = UBound(kData, 1)
    Dim wsData As Variant ' Worksheets Data
    ReDim wsData(1 To kRows)
    Dim tRows As Long
    tRows = 1 ' for header
    Dim i As Long
    For i = 2 To kRows
        wsData(i) = getRange(defineRangeUsingFirstCell( _
            wb.Worksheets(kData(i, 1)).Cells(kData(i, 2), 1)))
        tRows = tRows + UBound(wsData(i), 1) - 1
    Next i
    Dim kCols As Long
    kCols = UBound(kData, 2)
    
    ' Define Result Data array.
    Dim rData As Variant ' Result Data
    ReDim rData(1 To tRows, 1 To kCols)
    
    Dim hData As Variant ' Header Data
    Dim CurrCol As Variant
    Dim wsRows As Long
    Dim CurrRow As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim m As Long
    
    ' Write headers.
    For j = 1 To kCols
        rData(1, j) = kData(1, j)
    Next j
    ' Write body.
    CurrRow = 1
    For i = 2 To kRows
        ReDim hData(1 To UBound(wsData(i), 2))
        For j = 1 To UBound(wsData(i), 2)
            hData(j) = wsData(i)(1, j)
        Next j
        wsRows = UBound(wsData(i), 1)
        For l = 1 To 2
            For k = 2 To wsRows
                rData(CurrRow + k - 1, l) = kData(i, l)
            Next k
        Next l
        For l = 3 To kCols
            CurrCol = Application.Match(kData(i, l), hData, 0)
            For k = 2 To wsRows
                rData(CurrRow + k - 1, l) = wsData(i)(k, CurrCol)
            Next k
        Next l
        CurrRow = CurrRow + wsRows - 1
    Next i
        
    ' Write values from Result Data array to Result Range.
    With wb.Worksheets(rName).Range(rFirst).Resize(, kCols)
        .Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
        .Resize(tRows).Value = rData
    End With

End Sub

Function defineRangeUsingFirstCell(FirstCell As Range) As Range
    On Error GoTo clearError
    With FirstCell
        Dim rng As Range
        Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1, _
            .Worksheet.Columns.Count - .Column + 1)
    End With
    With rng
        Dim cel As Range
        Set cel = .Find(What:="*", LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        Set cel = .Worksheet.Cells(cel.Row, .Find(What:="*", _
            SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column)
        Set defineRangeUsingFirstCell = .Resize( _
            cel.Row - .Row + 1, cel.Column - .Column + 1)
    End With
ProcExit:
    Exit Function
clearError:
    Resume ProcExit
End Function

Function getRange(rng As Range) As Variant
    On Error GoTo clearError
    With rng
        Dim Data As Variant
        If .Rows.Count > 1 Or .Columns.Count > 1 Then
            Data = .Value
        Else
            ReDim Data(1 To 1, 1 To 1)
            Data(1, 1) = .Value
        End If
    End With
    getRange = Data
ProcExit:
    Exit Function
clearError:
    Resume ProcExit
End Function

推荐阅读