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

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

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