如何将特定范围复制到 VBA 中的新工作表中？

Question

我正在尝试创建一个宏，它将工作簿中所有工作表中的特定列编译成一个新工作表。

到目前为止，我创建了新工作表，并为每列返回正确的标题，但复制现有工作表中的所有列，而不仅仅是我指定的列。

从列标题可以看出，我只想从第 2 页开始将 A:I、K:M、R 和 W:Y 列中的值复制到“MASTER”中的 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

Answer 1

以与标题相同的方式依次复制/粘贴每个范围。 （未经测试）

    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) & "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 的范围上缺少一个点

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