We received an excel file with 70 sheets. It might have generated through some application. One of the requirements was to remove duplicate lines across all sheets. Thus we needed to combine all sheets into one, for further analysis. Fortunately all sheets were in same headers and same format. We had to combine them all into sheet. We accomplished this task with the below script. If you have same requirement follow below steps.
- Open the excel file which has multiple sheets
- Press Alt+F11 to open VBA screen
- Create new module
- Insert below VBA script inside the module
- The script will create a new sheet by name "Combine" and copy-paste all sheets into this one sheet
- Also the script will capture each sheet name and paste the data with respective sheet name
Sub CombineSheets()
Dim ws As Worksheet, wsCombine As Worksheet
Dim rg As Range
Dim RowCombine As Integer
Set wsCombine = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))
wsCombine.Name = "Combine"
RowCombine = 1
For Each ws In ThisWorkbook.Worksheets
If ws.Index <> 1 Then
Set rg = ws.Cells(1, 1).CurrentRegion
rg.Copy wsCombine.Cells(RowCombine, 2)
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)).NumberFormat = "@"
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)) = ws.Name
RowCombine = RowCombine + rg.Rows.Count
End If
Next
wsCombine.Cells(1, 1).EntireColumn.AutoFit
Set rg = Nothing
Set wsCombine = Nothing
End Sub
Dim ws As Worksheet, wsCombine As Worksheet
Dim rg As Range
Dim RowCombine As Integer
Set wsCombine = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))
wsCombine.Name = "Combine"
RowCombine = 1
For Each ws In ThisWorkbook.Worksheets
If ws.Index <> 1 Then
Set rg = ws.Cells(1, 1).CurrentRegion
rg.Copy wsCombine.Cells(RowCombine, 2)
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)).NumberFormat = "@"
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)) = ws.Name
RowCombine = RowCombine + rg.Rows.Count
End If
Next
wsCombine.Cells(1, 1).EntireColumn.AutoFit
Set rg = Nothing
Set wsCombine = Nothing
End Sub
No comments:
Post a Comment