2

以下は、各シートの最後の列からデータをフェッチして、シート「MainSheet」に表示するためのコードです。最後の列がセルをマージしたため、このコードはその間のセルも削除しますこのコードはデータをメインシートに垂直ビューとして表示し、水平にします。つまり、各シートの最後の列のデータをフェッチして、 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

前もって感謝します

4

1 に答える 1

2

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
于 2012-04-23T09:34:54.563 に答える