Блог

Я пытаюсь создать макрос, который скомпилирует определенные столбцы из всех листов в книге в один новый лист.

То, что у меня есть до сих пор, создает новый лист и возвращает правильные заголовки для каждого столбца, но копирует все столбцы из существующих листов, а не только указанные мной столбцы.

Как видно из заголовков столбцов, я хотел бы скопировать значения только в столбцах A:I, K:M, R и W:Y с листов 2 и далее в столбцы B:O на листе «МАСТЕР».

У кого-нибудь есть какие-либо предложения относительно того, как я могу заставить это работать?

 Sub Combine2()
    Dim J As Integer, wsNew As Worksheet
    Dim rngCopy As Range, rngPaste As Range
    Dim Location As String

    On Error Resume Next
    Set wsNew = Sheets("MASTER")
    On Error GoTo 0
        'if sheet does not already exist, create it
        If wsNew Is Nothing Then
        Set wsNew = Worksheets.Add(Before:=Sheets(1)) ' add a sheet in first place
        wsNew.Name = "MASTER"
    End If
    


    'copy headings and paste to new sheet starting in B1
    With Sheets(2)
        .Range("A1:I1").Copy wsNew.Range("B1")
        .Range("R1").Copy wsNew.Range("K1")
        .Range("K1:M1").Copy wsNew.Range("L1")
        .Range("W1:Y1").Copy wsNew.Range("O1")
        
    End With

    ' work through sheets
    For J = 2 To Sheets.Count ' from sheet 2 to last sheet
        'save sheet name/location to string
        Location = Sheets(J).Name

        'set range to be copied
        With Sheets(J).Range("A1").CurrentRegion
            Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1)
        End With

        'set range to paste to, beginning with column B
        Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)

        'copy range and paste to column *B* of combined sheet
        rngCopy.Copy rngPaste

        'enter the location name in column A for all copied entries
        Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location

    Next J
    
        With Sheets(1)
            Range("A1").Value = "Extract Date"
            Range("A1").Font.Bold = True
            Columns("A:T").AutoFit
        End With
        
    ' wsNew.Visible = xlSheetHidden
    
        
End Sub

 

Скопируйте/вставьте каждый диапазон по очереди таким же образом, как и для заголовков. (непроверено)

     Dim ar(4), k as Integer
    ar(1) = array("A1:I1","B")
    ar(2) = array("R1","K")
    ar(3) = array("K1:M1","L")
    ar(4) = array("W1:Y1","O")

    'copy headings and paste to new sheet
    With Sheets(2)
        For k = 1 to Ubound(ar)
            .Range(ar(k)(0)).Copy wsNew.Range(ar(k)(1) amp; "1")
        Next
    End With

    ' work through sheets
    Dim lr As Long
    For J = 2 To Sheets.Count ' from sheet 2 to last sheet
        'save sheet name/location to string
        Location = Sheets(J).Name

        'set range to be copied
        With Sheets(J)
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            For k = 1 to Ubound(ar)
                Set rngCopy = .Range(ar(k)(0)).Offset(1).Resize(lr-1)

                'set range to paste to, beginning with column B
                Set rngPaste = wsNew.Cells(Rows.Count, ar(k)(1)).End(xlUp).Offset(1, 0)

                'copy range and paste to combined sheet
                rngCopy.Copy rngPaste

                If k = 1 Then
                    'enter the location name in column A for all copied entries
                    Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location
                End If
            Next
        End With
       
    Next J
 

Примечание. В этом блоке отсутствует точка на диапазонах для использования с

 With Sheets(1)
     Range("A1").Value = "Extract Date"
     Range("A1").Font.Bold = True
     Columns("A:T").AutoFit
End With