Copy Range to a new worksheet - vba

Question

I am trying to write a macro to copy a range of data from different parts of a worksheet and paste it to a new worksheet. It should do this for every worksheet in the workbook with a few specified exceptions. This is the code I have written so far:
Dim wb As Workbook
Dim ws As Worksheet
Dim Rng As Range
'create new worksheet, name it "Budget"
Set ws = Sheets.Add
ws.Name = "Budget"
'set column titles in the new sheet
Range("A1").Value = "Period"
Range("B1").Value = "Country"
Range("C1").Value = "Product Line"
Range("D1").Value = "Currency"
Range("E1").Value = "Sales"
'search the entire UsedRange of sheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Summary" And ws.Name <> "Template" And ws.Name <> "Data" Then
With ws.UsedRange
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Offset(1, 0).Resize(33)
Sheets("Budget").[F1].End(xlDown).Offset(0, -3).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value 'put values from the Find into C column of new sheet
Set Rng = .Find(What:="201601", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Offset(1, 0).Resize(33)
Sheets("Budget").[F1].End(xlDown).Offset(0, -1).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value 'put values from the Find into D column of new sheet
End With
End If
Next ws
End Sub
The first part seems to work fine, but when it reaches the second "Set Rng" it doesn't go any further. I am looking to set 5 different ranges to take data from.

Answer 1

I've added this as an answer as it's too long to fit in a comment. It's not a perfect answer, but will hopefully highlight a couple of areas to look at.
Each range reference also includes which sheet it's looking at (omitting the sheet reference tells Excel to use the currently active sheet).
An array to populate the headings.
SELECT CASE instead of IF
Space to do something if the FIND's aren't found. You say they're all the same, but that's in a perfect world and I haven't found that yet.
Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsBudget As Worksheet
Dim Rng As Range
Dim rUsedRange As Range
Set wb = ActiveWorkbook
'create new worksheet, name it "Budget"
Set wsBudget = wb.Sheets.Add
With wsBudget
.Name = "Budget"
.Range("A1:E1") = Array("Period", "Country", "Product Line", "Currency", "Sales")
End With
'search the entire UsedRange of sheet.
'ActiveWorkbook or ThisWorkbook?
For Each ws In wb.Worksheets
Select Case ws.Name
Case "Summary", "Template", "Data"
'Do Nothing
Case Else
Set rUsedRange = ws.Range(ws.Cells(1, 1), LastCell(ws))
With rUsedRange
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1, 0).Resize(33).Copy _
Destination:=wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count)
Else
'Do something else if Rng not found.
End If
Set Rng = .Find(What:=201601, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1).Resize(33).Copy _
Destination:=wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count)
Else
'Do something if Rng not found.
End If
End With
End Select
Next ws
End Sub
Have included the find last cell function:
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function

Answer 2

This is what I have so far...
Sub Test()
' CreateBudgetFormat Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim wsBudget As Worksheet
Dim Rng As Range
Dim rUsedRange As Range
Set wb = ActiveWorkbook
'create new worksheet, name it "Budget"
Set wsBudget = wb.Sheets.Add
With wsBudget
.Name = "Budget"
.Range("A1:E1") = Array("Period", "Country", "Product Line", "Currency", "Sales")
End With
'search the entire UsedRange of sheet.
For Each ws In wb.Worksheets
Select Case ws.Name
Case "Summary", "Template", "Data"
'Do Nothing
Case Else
For x = 201601 To 201612
Set rUsedRange = ws.Range(ws.Cells(1, 1), LastCell(ws))
With rUsedRange
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1, 0).Resize(32).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something else if Rng not found.
End If
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(37, 0).Resize(2).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something else if Rng not found.
End If
Set Rng = .Find(What:=x, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1, 0).Resize(32).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
Set Rng = .Find(What:=x, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(37, 0).Resize(2).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
Set Rng = .Find(What:="Ship_To_Country", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(, 1).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -4).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
Set Rng = .Find(What:=x, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Copy
wsBudget.Range("F1").End(xlDown).Offset(, -5).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
End With
Next
End Select
Next ws
With wsBudget
Range("D2") = "EUR"
Range("C2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
End With
End Sub
It works although far from an ideal code. I would appreciate any help on how I can change this [ wsBudget.Range("F1").End(xlDown).Offset(, -5).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats ] to resize filldown as opposed to having to specify a number of rows (34 in this case). Also any other suggestions of how I can improve the code will be welcome. Thanks!