☰

如何水平合并 Excel 表（固定行数）？

tag-icon • tag-icon microsoft-excel
如何水平合并 Excel 表（固定行数）？

我有一个工作簿，里面有几十张结构相同的不同工作表

看

示例表 1

我需要做的是将所有工作表合并为一张，通过将所有工作表的所有列“粘贴”在一起，以便在包含所有数据的表中我仍然有 N 行（即，行数与国家数一样多，我需要结果工作表看起来像：

见截图2

如有任何建议我将不胜感激！

答案1

以下是一些将它们全部合并的代码。行标题（append_data 表的 a 列）来自其复制的最后一个选项卡的 a 列。

Sub Append_Data_From_Different_Sheets_Into_Single_Sheet_By_Column()
'Procedure to Consolidate all sheets in a workbook

On Error GoTo IfError

'1. Variables declaration   
Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstCol As Long
Dim i As Integer, EnRange As String  
Dim SrcRng As Range

'2. Disable Screen Updating - stop screen flickering 
'   And Disable Events to avoid inturupted dialogs / popups
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
 End With

'3. Delete the Append_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Append_Data").Delete
Application.DisplayAlerts = True

'4. Add a new WorkSheet and name as 'Append_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Append_Data"
End With

'5. Loop through each WorkSheet in the workbook and copy the data to the 'Append_Data' 
WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
   If Sht.Name <> DstSht.Name Then
      '5.1: Find the last row on the 'Append_Data' sheet
       DstCol = fn_LastColumn(DstSht)
       
       If DstCol = 1 Then DstCol = 0
           
       '5.2: Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange = Sht.Cells(LstRow, LstCol).Address
       Set SrcRng = Sht.Range("A1:" & EnRange)
   
       '5.3: Check whether there are enough columns in the 'Append_Data' Worksheet
        If DstCol + SrcRng.Columns.Count > DstSht.Columns.Count Then
            MsgBox "There are not enough columns to place the data in the Append_Data worksheet."
            GoTo IfError
        End If
            
      '5.4: Copy data to the 'Append_Data' WorkSheet
        SrcRng.Offset.Resize(SrcRng.Rows.Count, SrcRng.Columns.Count - 1).Offset(0, 
1).Copy Destination:=DstSht.Cells(1, DstCol + 1)
           End If
Next

ThisWorkbook.Worksheets("Append_Data").Range("a:a").EntireColumn.Insert
SrcRng.Resize(SrcRng.Rows.Count, 1).Copy Destination:=DstSht.Cells(1, 1)

IfError:
'6. Enable Screen Updating and Events
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub

'In this example we are finding the last Row of specified Sheet
'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)

    Dim lastRow As Long
    lastRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow

End Function

'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(ByVal Sht As Worksheet)

    Dim lastCol As Long
    lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol

End Function

相关内容