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

[rtr1811]

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]

Hi,
I do not get error91 at my side.
Can you please copy this latest code to a new module and try again? Thanks.

Option Explicit

Sub MergeSheets5()

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