excel - 从不同的工作表中获取列数据并将其作为 MainSheet 中的行数据

Question

以下是从每张工作表的最后一列获取数据并将其显示在工作表“MainSheet”中的代码。由于最后一列已合并单元格，此代码还会删除其间的单元格
此代码在 MainSheet 中将数据显示为垂直 View ，我想让它成为水平的，即每个工作表最后一列的数据应该被提取到 MainSheet 中的行，并且还应该注意合并的单元格

Sub CopyLastColumns()
    Dim cnt As Integer, sht As Worksheet, mainsht As Worksheet, col As Integer, rw As Integer
    ActiveSheet.Name = "MainSheet"
    Set mainsht = Worksheets("MainSheet")

    cnt = 1
    For Each sht In Worksheets
        If sht.Name <> "MainSheet" Then
            sht.Columns(sht.Range("A1").CurrentRegion.Columns.Count).Copy
            mainsht.Columns(cnt).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            mainsht.Cells(150, cnt) = sht.Range("A2")
            cnt = cnt + 1
        End If
    Next sht

    With mainsht
        For col = 1 To cnt
            For rw = .Cells(65536, col).End(xlUp).row To 1 Step -1
                If .Cells(rw, col) = "" Then
                    .Cells(rw, col).Delete Shift:=xlUp
                End If
            Next rw
        Next col
    End With
End Sub

提前致谢

Answer 1

此代码复制每个工作表的最后一列，并将它们作为行粘贴到 MainSheet 中，以保持合并单元格的完整性。

Option Explicit

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim wsOLrow As Long, wsILrow As Long, wsILcol As Long

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    Set wsO = Sheets("MainSheet")

    wsOLrow = wsO.Cells.Find(What:="*", _
              After:=wsO.Range("A1"), _
              Lookat:=xlPart, _
              LookIn:=xlFormulas, _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious, _
              MatchCase:=False).Row + 1

    For Each wsI In ThisWorkbook.Sheets
        If wsI.Name <> wsO.Name Then
            With wsI
                wsILrow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row

                wsILcol = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column

                .Range(Split(Cells(, wsILcol).Address, "$")(1) & "1:" & _
                Split(Cells(, wsILcol).Address, "$")(1) & _
                wsILrow).Copy .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
                Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)

                .Activate

                With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
                Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
                    .UnMerge

                    .Cells.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
                End With

                wsILrow = .Range(Split(Cells(, wsILcol).Address, "$")(1) & Rows.Count).End(xlUp).Row

                With .Range(Split(Cells(, wsILcol + 1).Address, "$")(1) & "1:" & _
                Split(Cells(, wsILcol + 1).Address, "$")(1) & wsILrow)
                    .Copy

                    wsO.Cells(wsOLrow, 1).PasteSpecial Paste:=xlPasteAll, _
                    Operation:=xlNone, SkipBlanks:=False, Transpose:=True

                    .Delete
                End With

                wsOLrow = wsOLrow + 1
            End With
        End If
    Next

LetsContinue:
    Application.ScreenUpdating = True
    MsgBox "Done"
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub