Help Merge Manys Sheets to Single Sheet

Youngdand

Board Regular
Joined
Sep 29, 2017
Messages
120
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.

Code:
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.
 

Some videos you may like

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

Youngdand

Board Regular
Joined
Sep 29, 2017
Messages
120
HI,

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

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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,768
Messages
5,626,754
Members
416,202
Latest member
donya ba

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top