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

Question

以下代码用于从每个工作表的最后一列中获取数据并将其显示在工作表“MainSheet”中。由于最后一列合并了单元格，因此此代码还会删除之间的单元格 此代码将数据显示为 MainSheet 中的垂直 View ，我想将其设置为水平 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