Help Merge Manys Sheets to Single Sheet

[Youngdand]

HI i have the following Macro which Merges multiple sheets to 3 consolidated sheets in a new workbook, bases on text within a sheet name, and also adds a column in a with the sheet name against every every item.

Sub Srlmerge()
Dim Master As Workbook
Dim current As Workbook
Dim cases As Worksheet, ws As Worksheet, PP As Worksheet, Payments As Worksheet
Dim LR As Long, NR As Long
Application.ScreenUpdating = False
Set current = ThisWorkbook
Set Master = Workbooks.Add

Set cases = Master.Worksheets.Add
cases.Name = "Cases"

For Each ws In current.Worksheets
If ws.Name Like "*Cases" Then

NR = cases.Range("A" & Rows.Count).End(xlUp).Row
LR = ws.Range("A" & Rows.Count).End(xlUp).Row
cases.Range("A" & NR & ":A" & NR + LR - 1) = ws.Name
current.Activate
ws.Range("A1:Z" & LR + 1).Copy cases.Range("B" & NR)
cases.Range("a1").Value = "Sheet Name"
End If
Next ws
cases.Columns("A:Z").AutoFit

Master.Activate
With cases.UsedRange
.AutoFilter , Field:=3, Criteria1:="PK_*"
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Select
Selection.Delete
End With
cases.AutoFilterMode = False

Set Payments = Master.Worksheets.Add
Payments.Name = "Payments"

For Each ws In current.Worksheets
If ws.Name Like "*Payment*" Then

NR = Payments.Range("B" & Rows.Count).End(xlUp).Row
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Payments.Range("A" & NR & ":A" & NR + LR - 1) = ws.Name
ws.Range("A1:Z" & LR + 1).Copy Payments.Range("B" & NR)
Payments.Range("a1").Value = "Sheet Name"
End If
Next ws
Payments.Columns("A:Z").AutoFit

With Payments.UsedRange
.AutoFilter , Field:=3, Criteria1:="PK_*"
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Select
Selection.Delete
End With
Payments.AutoFilterMode = False

Set PP = Master.Worksheets.Add
PP.Name = "Payment plans"

For Each ws In current.Worksheets
If ws.Name Like "*PP" Then

NR = PP.Range("A" & Rows.Count).End(xlUp).Row
LR = ws.Range("A" & Rows.Count).End(xlUp).Row
PP.Range("A" & NR & ":A" & NR + LR - 1) = ws.Name
ws.Range("A1:Z" & LR + 1).Copy PP.Range("B" & NR)
PP.Range("a1").Value = "Sheet Name"
End If
Next ws
PP.Columns("A:Z").AutoFit
With PP.UsedRange
.AutoFilter , Field:=3, Criteria1:="PK_*"
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Select
Selection.Delete
End With
PP.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

However, when stacking the individual sheets in to one it appears to be overwriting the last row from the previous sheet with the 1st item of the current sheet it is processing.

Can anyone point out where i have gone wrong?

Thanks in advance for your help.

Regards,
Dan.

 

[Youngdand]

HI,

Just as an update, i have managed to resolve this with the following code:

Sub ConsolidateSheets()
'Merge all sheets in a workbook into one summary sheet (stacked)
Dim Master As Workbook
Dim current As Workbook
Dim cases As Worksheet, ws As Worksheet, PP As Worksheet, Payments As Worksheet
Dim LR As Long, NR As Long
Application.ScreenUpdating = False
Set current = ThisWorkbook
Set Master = Workbooks.Add
Dim offset As Integer
offset = 0

Set cases = Master.Worksheets.Add
cases.Name = "Cases"

For Each ws In current.Worksheets
If ws.Name Like "*Cases" Then

NR = cases.Range("A" & Rows.Count).End(xlUp).Row
LR = ws.Range("A" & Rows.Count).End(xlUp).Row
cases.Range("A" & NR & ":A" & NR + LR - 1) = ws.Name ' March PP, April PP etc.
current.Activate
ws.Range("A" & (offset + 1) & ":Z" & LR + 1).Copy cases.Range("B" & NR + offset)
' ws.Range("A1:Z" & LR + 1).Copy cases.Range("B" & NR + LR - 1)
cases.Range("a1").Value = "Sheet Name"
If offset = 0 Then offset = 1
End If

Next ws
cases.Columns("A:Z").AutoFit
offset = 0

Set Payments = Master.Worksheets.Add
Payments.Name = "Payments"



For Each ws In current.Worksheets
If ws.Name Like "*Payment*" Then

NR = Payments.Range("B" & Rows.Count).End(xlUp).Row
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Payments.Range("A" & NR & ":A" & NR + LR - 1) = ws.Name
ws.Range("A" & (offset + 1) & ":Z" & LR + 1).Copy Payments.Range("B" & NR + offset)
Payments.Range("a1").Value = "Sheet Name"
If offset = 0 Then offset = 1
End If
Next ws

Payments.Columns("A:Z").AutoFit
offset = 0

Set PP = Master.Worksheets.Add
PP.Name = "Payment plans"

For Each ws In current.Worksheets
If ws.Name Like "*PP" Then

NR = PP.Range("A" & Rows.Count).End(xlUp).Row
LR = ws.Range("A" & Rows.Count).End(xlUp).Row
PP.Range("A" & NR & ":A" & NR + LR - 1) = ws.Name
ws.Range("A" & (offset + 1) & ":Z" & LR + 1).Copy PP.Range("B" & NR + offset)
PP.Range("a1").Value = "Sheet Name"
If offset = 0 Then offset = 1
End If
Next ws

PP.Columns("A:Z").AutoFit
Application.ScreenUpdating = True
End Sub