excel - How to copy specific ranges into a new worksheet in VBA?

Question

I'm trying to create a macro that will compile specific columns from all worksheets in a workbook into a single new worksheet.

What I have so far creates the new sheet, and returns the correct headers for each column, but copies across all columns from the existing sheets rather than just the columns I have specified.

As can be seen with the column headings, I would like to only copy the values in columns A:I, K:M, R and W:Y from sheets 2 onwards, into columns B:O in the "MASTER" worksheet.

Does anyone have any suggestions as to how I can get this working?

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

标签： excelvbaexcel-formulacopy-paste

Answer 1

Copy/paste each range in turn in the same way as you have for the headings. (untested)

    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

Note this block is missing a dot on the ranges to use the With

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