Merge Excel Multiple Sheets from a single work book to one sheet.

rtr1811 · Apr 20, 2024

Hi all,
I've to merge all the excel sheets in a excel work book to one sheet and customize a few things. Can any one help me with VBA code?

I've to Copy each and every row in the sheets 98, 100 & 101 to Wardwise. After that I've to insert a column called "Part" and copy & paste the number in the sheet to the column.

File for Merge Test

After Copying all the rows is completed, I've to sort the resultant file first by Column called Ward No, then bby Part and then by Page.

Input data is in sheet ns 98, 100 and 101 and the expected output is presented in sheet called Wardwise. How to do this?

JerrExcel · Apr 24, 2024

Hi there,

I am not sure if you are still looking for solution for this.
As you requested for VBA code, I assume you had basic understanding on setting up a macro in template. (using developer tool, adding module, copy paste module, run macro)

The way I will do it will be using simply copy paste VBA command as below:

Define all related sheets
Clear data in "Wardwise" [I assume you will need to redo the report routinely.]
Update any data in sheet "98", "100", "101" [I assume this is fixed name for those sheet, or else, you can edit the sheet name in the code]
Unmerge all cells in data, to allow filtering in later part of macro / prevent copy-paste errors.
Since all format from "98", "100", "101" will be the same every time, code will find last row for data for each sheet using "Net total"
Then start copy sheet "98" into "Wardwise", using range of columns, and assign Part as 98 (sheet name)
Then start copy sheet "100" into "Wardwise", using range of columns, and assign Part as 100 (sheet name)
Then start copy sheet "101" into "Wardwise", using range of columns, and assign Part as 101 (sheet name)
Sort all data by Ward No, then by Part, then by Page. (you can rearrange this in the code)
Remove autofilter
Msgbox "Done merged"

Try the code:

VBA Code:

Sub MergeSheets()

Dim wsD As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Set wsD = ThisWorkbook.Sheets("Wardwise")
Set ws1 = ThisWorkbook.Sheets("98") 'Change this if you have different named sheet
Set ws2 = ThisWorkbook.Sheets("100") 'Change this if you have different named sheet
Set ws3 = ThisWorkbook.Sheets("101") 'Change this if you have different named sheet

'delete previous data
wsD.Range("B6:R10000").Clear

'unmerge all cells
wsD.Range("B6:R10000").UnMerge
ws1.Range("B8:R10000").UnMerge
ws2.Range("B8:R10000").UnMerge
ws3.Range("B8:R10000").UnMerge

'count the lastrow of each sheets
Dim data_lastrow As Long
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1

'Find net total as last row
Dim FoundCell1 As Range
Const WHAT_TO_FIND1 As String = "Net Total"
Set FoundCell1 = ws1.Range("B:B").Find(What:=WHAT_TO_FIND1)
Dim data_lastrow1 As Long
data_lastrow1 = FoundCell1.Row

'Find net total as last row
Dim FoundCell2 As Range
Const WHAT_TO_FIND2 As String = "Net Total"
Set FoundCell2 = ws2.Range("B:B").Find(What:=WHAT_TO_FIND2)
Dim data_lastrow2 As Long
data_lastrow2 = FoundCell2.Row

'Find net total as last row
Dim FoundCell3 As Range
Const WHAT_TO_FIND3 As String = "Net Total"
Set FoundCell3 = ws3.Range("B:B").Find(What:=WHAT_TO_FIND3)
Dim data_lastrow3 As Long
data_lastrow3 = FoundCell3.Row

'copy sheets into Destination sheet
ws1.Range("C8:Q" & data_lastrow1).Copy Destination:=wsD.Range("D" & data_lastrow)
ws1.Range("B8:B" & data_lastrow1).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow1 - 8).Value = ws1.Name


'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1
ws2.Range("C8:Q" & data_lastrow2).Copy Destination:=wsD.Range("D" & data_lastrow)
ws2.Range("B8:B" & data_lastrow2).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow2 - 8).Value = ws2.Name

'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1
ws3.Range("C8:Q" & data_lastrow3).Copy Destination:=wsD.Range("D" & data_lastrow)
ws3.Range("B8:B" & data_lastrow3).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow3 - 8).Value = ws3.Name

'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes

wsD.AutoFilterMode = False

Set wsD = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing

MsgBox "Done merged"

End Sub

rtr1811 · Apr 25, 2024

Thanks for the reply. Only the prior data in the sheet called Wardwise is Cleared. I got Runtime Error while executing the code.

No. of Source Sheets may vary. It is not limited to 3. (not only 98, 100 & 101). It may be 2 or 8. So, Hard coding the sheets may not be helpful. Instead we have to loop through each sheet which has number as its name and copy the data.

After copying the data a column has to be inserted before ward no and the Name of the sheet (i.e 98 or 100 or 101) from which the data is copied has to be copied and pasted in all the cells. Then the sheet has to be sorted by Column called Ward No, then by Part and then by Page.

How to get around this error?

Thank you once again.

JerrExcel · Apr 25, 2024

Hi,

If there might be more sheets, let me try to put them in a LOOP. Will try to loop all other sheets except for "Wardwise". (code below)

For "Run time error 1004", this might be caused by the difference in our sheet "Wardwise". From your example sheet, there is merged cells:

I do not encourage merge cells as VBA cannot perform sort/filter/copypaste, and cannot recognize the correct row of header.

Here is my starting sheet for "Wardwise":

20240425 debug Pattadaikatti-Merge-Test.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

1

2

Panchayat Union - Melaneelithanallur

3

Panchayat - Pattadaikatti

4

Total voters

ST

SC

Others

5

Page no

Part

Ward no

Male

Female

TG

Male

Female

TG

Male

Female

TG

Male

Female

TG

Sub Total Male

Sub Total Female

Wardwise

By using same table header as my "Wardwise" sheet, try this code:

VBA Code:

Option Explicit

Sub MergeSheets2()

Dim wsD As Worksheet
Dim ws As Worksheet

Set wsD = ThisWorkbook.Sheets("Wardwise")

'delete previous data
wsD.Range("B6:R10000").Clear


Dim data_lastrow As Long
Dim FoundCell As Range
Dim data_lastrow1 As Long


For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Wardwise" Then
Else

'unmerge all cells
ws.Range("B8:R10000").UnMerge

'count the lastrow of each sheets
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1

'Find net total as last row
Const WHAT_TO_FIND As String = "Net Total"
Set FoundCell = ws.Range("B:B").Find(What:=WHAT_TO_FIND)
data_lastrow1 = FoundCell.Row

'copy sheets into Destination sheet
ws.Range("C8:Q" & data_lastrow1).Copy Destination:=wsD.Range("D" & data_lastrow)
ws.Range("B8:B" & data_lastrow1).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow1 - 8).Value = ws.Name

End If
Next ws

'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes

wsD.AutoFilterMode = False

Set wsD = Nothing
Set ws = Nothing

MsgBox "Done merged"

End Sub

rtr1811 · Apr 27, 2024

Thank you for the reply. It works with the modified Wardwise sheet and the code above.

I need a few more favors from you.

1. The rows which contain the Word "Total" are not needed. Either they can be deleted or skipped from copying from the respective sheets. Can you modify the code to meet out this need?

2. Sorting has to be done in the following order.
(i) Column D
(ii) Column C
(iii) Column B

3. I want to know the changes you made to the "Wardwise" sheet in order to adopt the same technique wherever needed.

I thank you once again for your help.

JerrExcel · Apr 28, 2024

Hi,

rtr1811 said:
Thank you for the reply. It works with the modified Wardwise sheet and the code above.

I need a few more favors from you.

1. The rows which contain the Word "Total" are not needed. Either they can be deleted or skipped from copying from the respective sheets. Can you modify the code to meet out this need?

2. Sorting has to be done in the following order.
(i) Column D
(ii) Column C
(iii) Column B

3. I want to know the changes you made to the "Wardwise" sheet in order to adopt the same technique wherever needed.

I thank you once again for your help.

For number 1:
I will add a loop to look for the word "*Total*", then delete entire row if found.

VBA Code:

'remove row contains TOTAL
Dim d As Long 'row number
d = 6
Do Until d = data_lastrow  'loop through each row
    If wsD.Cells(d, 2).Value Like "*" & "Total" & "*" Then
        wsD.Rows(d).EntireRow.Delete
    Else
        d = d + 1
    End If
Loop

For number 2:
Here is how I have coded the sequence of sorting:
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes
Which is Column D -> Column C -> Column B.
If this is not the end product you wanted, try swap the Column D with Column B. like this:
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes

For number 3:
From your original "Wardwise" sheet, simply select cell B4:D5, then click "Unmerge".
Then Cut word from cell B4:D4, and Paste into cell B5:D5, so that they become the table header just like the rest of the header (Row5).

Here is my updated code:

VBA Code:

Option Explicit

Sub MergeSheets3()

Dim wsD As Worksheet
Dim ws As Worksheet

Set wsD = ThisWorkbook.Sheets("Wardwise")

'delete previous data
wsD.Range("B6:R10000").Clear

Dim data_lastrow As Long
Dim FoundCell As Range
Dim data_lastrow1 As Long
    
    
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Wardwise" Then
Else
'unmerge all cells
ws.Range("B8:R10000").UnMerge


'count the lastrow of each sheets
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1

'Find net total as last row
Const WHAT_TO_FIND As String = "Net Total"
Set FoundCell = ws.Range("B:B").Find(What:=WHAT_TO_FIND)
data_lastrow1 = FoundCell.Row

'copy sheets into Destination sheet
ws.Range("C8:Q" & data_lastrow1).Copy Destination:=wsD.Range("D" & data_lastrow)
ws.Range("B8:B" & data_lastrow1).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow1 - 8).Value = ws.Name

End If
Next ws

'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 3).End(xlUp).Row + 1

'remove row contains TOTAL
Dim d As Long 'row number
d = 6
Do Until d = data_lastrow  'loop through each row
    If wsD.Cells(d, 2).Value Like "*" & "Total" & "*" Then
        wsD.Rows(d).EntireRow.Delete
    Else
        d = d + 1
    End If
Loop

'sort order D then C then B, change this for your preferences
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes

wsD.AutoFilterMode = False

Set wsD = Nothing
Set ws = Nothing

MsgBox "Done merged"

End Sub

rtr1811 · Apr 29, 2024

Ok. Thank you.

I will sort manually as in the attached image. The ouptut of the sort operation should be as in the attached excel file.

Panchayat Union - Melaneelithanallur
Panchayat - Pattadaikatti
			Total voters	ST	SC	Others
Page no	Part	Ward no	Male	Female	TG	Male	Female	TG	Male	Female	TG	Male	Female	TG
3	101	1	4	5								4	5	0
4	101	1	3	9								3	9	0
7	100	1	7	11								7	11	0
8	100	1	1	0								1	0	0
9	100	1	5	4								5	4	0
9	101	1	0	1								0	1	0
10	101	1	6	6								6	6	0
11	101	1	0	3								0	3	0
12	101	1	0	1								0	1	0
13	101	1	0	1								0	1	0
15	100	1	2	1								2	1	0
15	101	1	1	1								1	1	0
16	100	1	0	1								0	1
16	101	1	5	4								5	4	0
17	101	1	4	5								4	5	0
19	101	1	2	1								2	1	0
20	100	1	3	2								3	2	0
20	101	1	4	1								4	1	0
25	101	1	1	1								1	1	0
26	101	1	13	11								13	11	0
29	101	1	3	7								3	7	0
30	101	1	1	3								1	3	0
31	101	1	3	2								3	2	0
33	100	1	10	7								10	7	0
33	101	1	1	2								1	2	0
34	100	1	17	13								17	13	0
34	101	1	5	6								5	6	0
35	100	1	14	16								14	16	0
36	100	1	15	15								15	15	0
37	100	1	17	13								17	13	0
38	100	1	14	16								14	16	0
39	100	1	15	14								15	14	0
40	100	1	1	2								1	2	0
42	100	1	1	0								1	0	0
ADD 1	100	1	2	2								2	2	0
ADD 1	101	1	2	3								2	3	0
ADD 2	101	1	6	4								6	4
DEL 2	100	1	2	4								2	4
3	98	2	3	2								3	2	0
4	98	2	7	5								7	5	0
5	98	2	4	0								4	0	0
6	98	2	2	2								2	2	0
7	98	2	6	11								6	11	0
8	98	2	12	12								12	12	0
9	98	2	14	14								14	14	0
10	98	2	11	6								11	6	0
17	98	2	0	1								0	1	0
21	98	2	2	3								2	3
22	98	2	2	4								2	4
23	98	2	7	4								7	4
24	98	2	5	5								5	5
25	98	2	7	3								7	3
26	98	2	3	5								3	5
27	98	2	1	2								1	2
28	98	2	5	5								5	5
29	98	2	6	5								6	5
30	98	2	12	7								12	7
31	98	2	14	16								14	16
32	98	2	14	16								14	16
33	98	2	13	13								13	13
34	98	2	14	16								14	16
35	98	2	6	9								6	9
37	98	2	3	8								3	8
ADD 1	98	2	1	3								1	3
ADD 2	98	2	3	1								3	1
DEL 3	98	2	0	1								0	1
3	101	3	3	5								3	5	0
4	101	3	6	6								6	6	0
5	101	3	1	1								1	1	0
6	100	3	1	10								1	10	0
8	100	3	5	4								5	4	0
8	101	3	11	8								11	8	0
9	100	3	1	0								1	0	0
9	101	3	3	9								3	9	0
10	101	3	6	6								6	6	0
13	100	3	3	1								3	1
14	100	3	1	1								1	1
15	101	3	2	1								2	1	0
18	100	3	0	1								0	1	0
20	101	3	0	2								0	2	0
24	101	3	1	0								1	0	0
25	101	3	2	4								2	4	0
26	100	3	4	3								4	3	0
26	101	3	0	2								0	2	0
27	100	3	15	14								15	14	0
27	101	3	1	2								1	2	0
28	100	3	8	9								8	9	0
29	100	3	12	10								12	10	0
29	101	3	8	3								8	3	0
30	100	3	12	8								12	8	0
31	100	3	12	13								12	13	0
32	100	3	18	12								18	12	0
33	100	3	6	7								6	7	0
33	101	3	2	1								2	1	0
34	101	3	1	1								1	1	0
40	100	3	16	11								16	11	0
41	100	3	3	5								3	5	0
42	100	3	5	3								5	3	0
ADD 1	101	3	1	2								1	2
ADD 2	101	3	1	4								1	4
DEL 3	101	3	2	4								2	4
3	98	4	4	13								4	13	0
4	98	4	9	3								9	3	0
7	98	4	0	1								0	1	0
8	98	4	1	3								1	3	0
10	98	4	5	7								5	7	0
11	98	4	13	17								13	17	0
12	98	4	19	11								19	11	0
13	98	4	16	14								16	14	0
14	98	4	19	11								19	11	0
15	98	4	13	17								13	17	0
16	98	4	14	16								14	16	0
17	98	4	15	10								15	10	0
18	98	4	3	5								3	5	0
19	98	4	6	5								6	5	0
20	98	4	2	1								2	1	0
21	98	4	4	7								4	7
22	98	4	1	2								1	2
23	98	4	3	2								3	2
28	98	4	5	4								5	4
29	98	4	2	0								2	0
30	98	4	5	6								5	6
33	98	4	1	1								1	1
35	98	4	1	1								1	1
36	98	4	4	2								4	2
ADD 1	98	4	1	7								1	7
ADD 2	98	4	1	0								1	0
DEL 3	98	4	0	1								0	1
3	101	5	1	1								1	1	0
5	100	5	1	3								1	3	0
5	101	5	8	16								8	16	0
6	100	5	1	0								1	0
6	101	5	17	13								17	13	0
7	101	5	3	4								3	4	0
8	101	5	6	3								6	3	0
9	101	5	8	7								8	7	0
10	100	5	1	0								1	0
10	101	5	4	2								4	2	0
11	101	5	11	10								11	10	0
12	101	5	12	13								12	13	0
13	101	5	14	15								14	15	0
14	101	5	18	12								18	12	0
15	101	5	11	13								11	13	0
16	100	5	1	1								1	1	0
16	101	5	8	12								8	12	0
17	101	5	11	10								11	10	0
18	101	5	13	17								13	17	0
19	100	5	1	0								1	0	0
19	101	5	4	5								4	5	0
21	100	5	1	0								1	0
24	100	5	3	0								3	0
25	100	5	0	2								0	2
26	100	5	1	0								1	0
30	101	5	5	5								5	5	0
34	101	5	2	3								2	3	0
41	100	5	13	9								13	9	0
42	100	5	3	7								3	7	0
ADD 1	100	5	0	3								0	3
ADD 1	101	5	4	7								4	7
ADD 2	101	5	2	0								2	0
DEL 2	100	5	1	1								1	1
DEL 3	101	5	2	0								2	0
3	98	6	4	4								4	4	0
4	98	6	4	2								4	2	0
5	98	6	15	11								15	11	0
6	98	6	9	17								9	17	0
7	98	6	6	6								6	6	0
8	98	6	0	2								0	2	0
9	98	6	1	1								1	1	0
10	98	6	0	1								0	1	0
17	98	6	2	2								2	2	0
18	98	6	12	10								12	10	0
19	98	6	9	10								9	10	0
20	98	6	2	2								2	2
21	98	6	7	7								7	7
22	98	6	11	10					2	1		9	9
23	98	6	4	10								4	10
24	98	6	14	6								14	6
25	98	6	11	9								11	9
26	98	6	10	12								10	12
27	98	6	14	13								14	13
28	98	6	5	6								5	6
29	98	6	9	8								9	8
33	98	6	1	1								1	1
35	98	6	6	7					6	5		0	2
36	98	6	5	4					1	0		4	4
37	98	6	9	4								9	4
ADD 1	98	6	2	0					1	0		1	0
ADD 2	98	6	2	3					1	1		1	2
3	101	7	4	6					2	0		2	6	0
4	101	7	2	4								2	4	0
5	101	7	3	1								3	1	0
6	100	7	1	1								1	1
7	100	7	2	10								2	10	0
7	101	7	13	10								13	10	0
8	100	7	7	4								7	4	0
9	100	7	4	6								4	6	0
10	100	7	1	1								1	1	0
11	101	7	0	1								0	1	0
12	101	7	2	2					2	2		0	0	0
15	101	7	0	1								0	1	0
17	100	7	0	2								0	2
18	100	7	3	1								3	1	0
19	101	7	13	5								13	5	0
20	101	7	11	12								11	12	0
21	101	7	17	13					4	5		13	8	0
22	101	7	15	15					13	10		2	5	0
23	101	7	11	19					10	13		1	6	0
24	101	7	13	16					13	16		0	0	0
25	101	7	9	13						12		9	1	0
26	101	7	3	1								3	1	0
27	100	7	0	1								0	1	0
27	101	7	1	2								1	2	0
28	100	7	8	5								8	5	0
28	101	7	0	1								0	1	0
29	100	7	4	4					1	1		3	3	0
29	101	7	3	6								3	6	0
30	100	7	2	8					1	1		1	7	0
30	101	7	6	10								6	10	0
31	100	7	3	2					2	2		1	0	0
31	101	7	14	7								14	7	0
32	101	7	4	8								4	8	0
33	101	7	7	5					4	5		3	0	0
34	101	7	2	1					1	1		1	0	0
ADD 1	100	7	0	3								0	3
ADD 1	101	7	2	0								2	0
ADD 2	101	7	3	9					0	4		3	5
DEL 2	100	7	0	1								0	1
DEL 3	101	7	3	1					1	0		2	1
5	100	8	9	10								9	10	0
6	100	8	7	7								7	7	0
8	100	8	0	1								0	1	0
14	100	8	0	2								0	2	0
16	100	8	1	1								1	1	0
16	101	8	1	0								1	0	0
17	100	8	1	2								1	2	0
19	100	8	3	2								3	2	0
20	100	8	14	10								14	10	0
21	100	8	15	14								15	14	0
22	100	8	18	12								18	12	0
23	100	8	15	15								15	15	0
24	100	8	10	17								10	17	0
25	100	8	11	17								11	17	0
26	100	8	8	14								8	14	0
27	101	8	12	12								12	12	0
32	101	8	6	8								6	8	0
33	101	8	4	8								4	8	0
DEL 2	100	8	1	3								1	3
3	100	9	13	17								13	17	0
3	101	9	1	0								1	0	0
4	100	9	12	18								12	18	0
5	100	9	3	4								3	4	0
6	100	9	2	0								2	0	0
8	100	9	3	5								3	5	0
8	101	9	2	0								2	0	0
9	100	9	2	8								2	8	0
9	101	9	1	1								1	1	0
10	100	9	12	15								12	15	0
11	100	9	15	15								15	15	0
11	101	9	3	2								3	2	0
12	100	9	15	15								15	15	0
13	100	9	12	14								12	14	0
14	100	9	15	11								15	11	0
15	100	9	10	17								10	17	0
16	100	9	13	12								13	12	0
17	100	9	10	15								10	15	0
18	100	9	15	10					2	3		13	7	0
19	100	9	11	13								11	13	0
20	100	9	0	1								0	1	0
31	101	9	2	2								2	2	0
32	101	9	3	1								3	1	0
39	100	9	0	1								0	1
ADD 1	101	9	2	3								2	3
ADD 2	101	9	2	5								2	5
DEL 2	100	9	2	0								2	0

JerrExcel · Apr 29, 2024

Hi,

I have play around with the sorting, according to your manually sorted list.
It seems that the sequence of sorting should be Column C -> Column B -> Column D.

Here is the updated code:

VBA Code:

Option Explicit

Sub MergeSheets4()

Dim wsD As Worksheet
Dim ws As Worksheet

Set wsD = ThisWorkbook.Sheets("Wardwise")

'delete previous data
wsD.Range("B6:R10000").Clear

Dim data_lastrow As Long
Dim FoundCell As Range
Dim data_lastrow1 As Long
    
    
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Wardwise" Then
Else
'unmerge all cells
ws.Range("B8:R10000").UnMerge


'count the lastrow of each sheets
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1

'Find net total as last row
Const WHAT_TO_FIND As String = "Net Total"
Set FoundCell = ws.Range("B:B").Find(What:=WHAT_TO_FIND)
data_lastrow1 = FoundCell.Row

'copy sheets into Destination sheet
ws.Range("C8:Q" & data_lastrow1).Copy Destination:=wsD.Range("D" & data_lastrow)
ws.Range("B8:B" & data_lastrow1).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow1 - 8).Value = ws.Name

End If
Next ws

data_lastrow = wsD.Cells(Rows.Count, 3).End(xlUp).Row + 1

'remove row contains TOTAL
Dim d As Long 'row number
d = 6
Do Until d = data_lastrow  'loop through each row
    If wsD.Cells(d, 2).Value Like "*" & "Total" & "*" Then
        wsD.Rows(d).EntireRow.Delete
    Else
        d = d + 1
    End If
Loop

'refresh last row of destination sheet
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes

wsD.AutoFilterMode = False

Set wsD = Nothing
Set ws = Nothing

MsgBox "Done merged"

End Sub

rtr1811 · May 2, 2024

JerrExcel said:

Hi there,

I am not sure if you are still looking for solution for this.
As you requested for VBA code, I assume you had basic understanding on setting up a macro in template. (using developer tool, adding module, copy paste module, run macro)

The way I will do it will be using simply copy paste VBA command as below:

Define all related sheets
Clear data in "Wardwise" [I assume you will need to redo the report routinely.]
Update any data in sheet "98", "100", "101" [I assume this is fixed name for those sheet, or else, you can edit the sheet name in the code]
Unmerge all cells in data, to allow filtering in later part of macro / prevent copy-paste errors.
Since all format from "98", "100", "101" will be the same every time, code will find last row for data for each sheet using "Net total"
Then start copy sheet "98" into "Wardwise", using range of columns, and assign Part as 98 (sheet name)
Then start copy sheet "100" into "Wardwise", using range of columns, and assign Part as 100 (sheet name)
Then start copy sheet "101" into "Wardwise", using range of columns, and assign Part as 101 (sheet name)
Sort all data by Ward No, then by Part, then by Page. (you can rearrange this in the code)
Remove autofilter
Msgbox "Done merged"

Try the code:

VBA Code:

Sub MergeSheets()

Dim wsD As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Set wsD = ThisWorkbook.Sheets("Wardwise")
Set ws1 = ThisWorkbook.Sheets("98") 'Change this if you have different named sheet
Set ws2 = ThisWorkbook.Sheets("100") 'Change this if you have different named sheet
Set ws3 = ThisWorkbook.Sheets("101") 'Change this if you have different named sheet

'delete previous data
wsD.Range("B6:R10000").Clear

'unmerge all cells
wsD.Range("B6:R10000").UnMerge
ws1.Range("B8:R10000").UnMerge
ws2.Range("B8:R10000").UnMerge
ws3.Range("B8:R10000").UnMerge

'count the lastrow of each sheets
Dim data_lastrow As Long
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1

'Find net total as last row
Dim FoundCell1 As Range
Const WHAT_TO_FIND1 As String = "Net Total"
Set FoundCell1 = ws1.Range("B:B").Find(What:=WHAT_TO_FIND1)
Dim data_lastrow1 As Long
data_lastrow1 = FoundCell1.Row

'Find net total as last row
Dim FoundCell2 As Range
Const WHAT_TO_FIND2 As String = "Net Total"
Set FoundCell2 = ws2.Range("B:B").Find(What:=WHAT_TO_FIND2)
Dim data_lastrow2 As Long
data_lastrow2 = FoundCell2.Row

'Find net total as last row
Dim FoundCell3 As Range
Const WHAT_TO_FIND3 As String = "Net Total"
Set FoundCell3 = ws3.Range("B:B").Find(What:=WHAT_TO_FIND3)
Dim data_lastrow3 As Long
data_lastrow3 = FoundCell3.Row

'copy sheets into Destination sheet
ws1.Range("C8:Q" & data_lastrow1).Copy Destination:=wsD.Range("D" & data_lastrow)
ws1.Range("B8:B" & data_lastrow1).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow1 - 8).Value = ws1.Name


'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1
ws2.Range("C8:Q" & data_lastrow2).Copy Destination:=wsD.Range("D" & data_lastrow)
ws2.Range("B8:B" & data_lastrow2).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow2 - 8).Value = ws2.Name

'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1
ws3.Range("C8:Q" & data_lastrow3).Copy Destination:=wsD.Range("D" & data_lastrow)
ws3.Range("B8:B" & data_lastrow3).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow3 - 8).Value = ws3.Name

'refresh last row of destination sheet
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes

wsD.AutoFilterMode = False

Set wsD = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing

MsgBox "Done merged"

End Sub

Thank you for the reply. It shows an runtime error. Run Time Error: 91. I have attached the image here with.

rtr1811 · May 2, 2024

JerrExcel said:

Hi,

I have play around with the sorting, according to your manually sorted list.
It seems that the sequence of sorting should be Column C -> Column B -> Column D.

Here is the updated code:

VBA Code:

Option Explicit

Sub MergeSheets4()

Dim wsD As Worksheet
Dim ws As Worksheet

Set wsD = ThisWorkbook.Sheets("Wardwise")

'delete previous data
wsD.Range("B6:R10000").Clear

Dim data_lastrow As Long
Dim FoundCell As Range
Dim data_lastrow1 As Long
   
   
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Wardwise" Then
Else
'unmerge all cells
ws.Range("B8:R10000").UnMerge


'count the lastrow of each sheets
data_lastrow = wsD.Cells(Rows.Count, 4).End(xlUp).Row + 1

'Find net total as last row
Const WHAT_TO_FIND As String = "Net Total"
Set FoundCell = ws.Range("B:B").Find(What:=WHAT_TO_FIND)
data_lastrow1 = FoundCell.Row

'copy sheets into Destination sheet
ws.Range("C8:Q" & data_lastrow1).Copy Destination:=wsD.Range("D" & data_lastrow)
ws.Range("B8:B" & data_lastrow1).Copy Destination:=wsD.Range("B" & data_lastrow)

wsD.Range("C" & data_lastrow & ":C" & data_lastrow + data_lastrow1 - 8).Value = ws.Name

End If
Next ws

data_lastrow = wsD.Cells(Rows.Count, 3).End(xlUp).Row + 1

'remove row contains TOTAL
Dim d As Long 'row number
d = 6
Do Until d = data_lastrow  'loop through each row
    If wsD.Cells(d, 2).Value Like "*" & "Total" & "*" Then
        wsD.Rows(d).EntireRow.Delete
    Else
        d = d + 1
    End If
Loop

'refresh last row of destination sheet
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("B5"), Order1:=xlAscending, Header:=xlYes
wsD.Range("B5:R" & data_lastrow).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlYes

wsD.AutoFilterMode = False

Set wsD = Nothing
Set ws = Nothing

MsgBox "Done merged"

End Sub

Thank you for the reply. It shows an runtime error. Run Time Error: 91. I have attached the image here with.

Merge Excel Multiple Sheets from a single work book to one sheet.

rtr1811

New Member

JerrExcel

New Member

rtr1811

New Member

JerrExcel

New Member

rtr1811

New Member

JerrExcel

New Member

rtr1811

New Member

Attachments

JerrExcel

New Member

rtr1811

New Member

Attachments

rtr1811

New Member

Attachments

Similar threads

Share this page

Merge Excel Multiple Sheets from a single work book to one sheet.

New Member

New Member

New Member

New Member

New Member

New Member

New Member

Attachments

New Member

New Member

Attachments

New Member

Attachments

Similar threads

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock