Solved: Combine Cells in multiple sheets into 1 sheet

[slamet Harto]

Dear expert,

Please help me on how to combine all cells that containing a value in multiple sheets into one sheet.

For example, there are various data in all cells , let say Cell A1 to A 65500 in sheet "Indonesia", and Cell A1 to C2500 in sheet "Europe" then no data at all in sheet "Africa".

I want to combine all sheets into a master sheet that called "Gabungan". So, every cells in master sheet will fullfil with those data.


I've write the following Vba code but I've a problem how to determine last cell in master sheet (see in red highlight)

Sub CombineCellintoMasterSheet()

Dim rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8, rng9 As Range
Dim Sht1, Sht2, Sht3, Sht4, Sht5, Sht6, Sht7, Sht8, Sht9, Sht10, MasterSht As Worksheet
Set Sht1 = Worksheets("Indonesia")
Set Sht2 = Worksheets("Africa")
Set Sht3 = Worksheets("Southeast Asia")
Set Sht4 = Worksheets("Australia & New Zealand")
Set Sht5 = Worksheets("Europe")
Set Sht6 = Worksheets("Middle East")
Set Sht7 = Worksheets("North America (USA)")
Set Sht8 = Worksheets("Latin America & Canada")
Set Sht9 = Worksheets("Others")
Set MasterSht = Worksheets("Gabungan")

With Sht1
Set rng1 = .Range("A1").CurrentRegion
End With
With Sht2
Set rng2 = .Range("A1").CurrentRegion
End With
With Sht3
Set rng3 = .Range("A1").CurrentRegion
End With
With Sht4
Set rng4 = .Range("A1").CurrentRegion
End With
With Sht5
Set rng5 = .Range("A1").CurrentRegion
End With
With Sht6
Set rng6 = .Range("A1").CurrentRegion
End With
With Sht7
Set rng7 = .Range("A1").CurrentRegion
End With
With Sht8
Set rng8 = .Range("A1").CurrentRegion
End With
With Sht9
Set rng9 = .Range("A1").CurrentRegion
End With
MasterSht.UsedRange.EntireRow.Delete
'Copy the first Range to the first cell of the MasterSheet
rng1.Copy MasterSht.Cells(1, 1)
'Copy the second Range and so on - To the first empty Cell of the MasterSheet
With MasterSht
rng2.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5) 'how to determine last cell ?
rng3.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
rng4.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
rng5.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
rng6.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
rng7.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
rng8.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
rng9.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
rng10.Copy .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 5)
End With
End Sub


Any reply and suggestions would be highly appreciate it.
Thank you in advance.
Harto

[Charlize]

Something like this ?Sub CombineCellintoMasterSheet()
Dim wsstart As Worksheet
Dim wsdest As Worksheet
Dim ws As Worksheet
Dim rng As Range
Set wsdest = ThisWorkbook.Worksheets("Gabungan")
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Gabungan" Then
Set wsstart = ws
ws.UsedRange.Copy
wsdest.Range("A" & wsdest.Range("A" & _
Rows.Count).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteAll
End If
Next ws
Application.CutCopyMode = False
End SubCharlize

[slamet Harto]

Hi Charlize

Thanks for the quick response.

I've added your suggestion, but it send a bug with run time error 1004 in this line wsdest.Range("A" & wsdest.Range("A" & _
Rows.Count).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteAll

As I've others 3 sheets with name Data Region, Data1 and Data2
and added your code with this:
Sub CombineCellintoMasterSheet2()
Dim wsstart As Worksheet
Dim wsdest As Worksheet
Dim ws As Worksheet
Dim rng As Range

Set wsdest = ThisWorkbook.Worksheets("Gabungan")
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Gabungan" Or Left(ws.Name, 4) = "Data" Then
Set wsstart = ws
ws.UsedRange.Copy
wsdest.Range("A" & wsdest.Range("A" & _
Rows.Count).End(xlUp).Offset(1, 0).Row).PasteSpecial xlPasteAll
End If
Next ws
Application.CutCopyMode = False
End Sub.

Could you please help me again to fix it.
Thanks a millions.
Rgds, Harto

[Charlize]

If you don't want to include the sheets with "Data" in the name, use <> instead of = .

Post a sample workbook with your problem. And which excel version are you using ?

Charlize

[slamet Harto]

Dear Charlize,

I'm using excel 2003.
Please find the attached for your reference.
Since the original file are huge then I've modified the file for sample only.

As a result, the data in sheet 1 to 5 will be combined in sheet Gabungan in entirecolumn A then B and so on.

Once again big Thanks.
Kind rgds, Harto

[Charlize]

You want to shift columns ? Try this possibility :Sub Gabungkan()
Dim wsstart As Worksheet
Dim wsdest As Worksheet
Dim ws As Worksheet
Dim mylastcell As Long
Dim mylastrow As Long
Set wsdest = ThisWorkbook.Worksheets("Gabungan")
For Each ws In ThisWorkbook.Worksheets
'We don't want to include Gabungan, Data?
If ws.Name <> "Gabungan" And Left(ws.Name, 4) <> "Data" Then
'I've deleted the remark/note you made on the sheet named 1
Set wsstart = ws
mylastrow = wsstart.UsedRange.Rows.Count
wsstart.UsedRange.Copy
mylastcell = wsdest.UsedRange.Columns.Count
If wsdest.Range("A1").Value <> vbNullString Or mylastcell > 1 Then
mylastcell = mylastcell + 1
End If
wsdest.Cells(1, mylastcell).PasteSpecial xlPasteAll
End If
Next ws
Application.CutCopyMode = False
End SubCharlize

[slamet Harto]

Dear Charlize

Wow.. excelent..
Thank you for your co-assistance. Highly appreciate it.
Best regards,
Harto

[slamet Harto]

Dear All,

Refer on my thread. I just have another problem on my vba code.
Can someone help me, if I want to combine all data in Master sheet as subsequently per column basis. For instance:
- Sheet 1, data in A1 to B933 have been copied to Gabungan Sheet in A1 to B933
- Sheet 2, data in A1 to A19 should have been copied to Gabungan Sheet in B934 to B952. Infact, the data has been transferred to the wrong cell.
- and so... ( loop until sheet "5" / end sheet)

I just modified the useful code from charlize
Sub Gabungkan()
Dim wsstart As Worksheet
Dim wsdest As Worksheet
Dim ws As Worksheet
Dim mylastcell As Long
Dim mylastrow As Long
Set wsdest = ThisWorkbook.Worksheets("Gabungan")
For Each ws In ThisWorkbook.Worksheets
'We don't want to include Gabungan, Data?
If ws.Name <> "Gabungan" And Left(ws.Name, 4) <> "Data" Then

Set wsstart = ws
mylastrow = wsstart.UsedRange.Rows.Count
wsstart.UsedRange.Copy
mylastcell = wsdest.UsedRange.Columns.Count
If wsdest.Range("A1").Value <> vbNullString Or mylastcell > 1 Then
mylastcell = mylastcell + 1
End If

Rem wsdest.Cells(1, mylastcell).PasteSpecial xlPasteAll
wsdest.Range("A" & wsdest.Range("A" & _
Rows.Count).End(xlUp).Offset(0, mylastcell).Row).PasteSpecial xlPasteAll
End If
Next ws
Application.CutCopyMode = False
End Sub


Infact, in Gabungan sheet all datas have been overlapping one to another cell.

As I'm new bie in vba your replies and suggestion would be appreciate it so much.

best regards,
Harto

[Charlize]

The no of columns to copy from each sheet must always be the same. Sub Gabungkan()
Dim wsstart As Worksheet
Dim wsdest As Worksheet
Dim ws As Worksheet
Dim mylastrow As Long
Dim myrowno As Long
Set wsdest = ThisWorkbook.Worksheets("Gabungan")
myrowno = wsdest.UsedRange.Rows.Count
myrowno = myrowno + 1
For Each ws In ThisWorkbook.Worksheets
'We don't want to include Gabungan, Data?
If ws.Name <> "Gabungan" And Left(ws.Name, 4) <> "Data" Then
'I've deleted the remark/note you made on the sheet named 1
Set wsstart = ws
mylastrow = wsstart.UsedRange.Rows.Count
wsstart.UsedRange.Copy
Call CheckCountry(ws.Name, wsstart, wsdest, myrowno)
End If
Next ws
Application.CutCopyMode = False
End Sub

Sub CheckCountry(ColumnHeader As String, myws As Worksheet, _
mywsdest As Worksheet, rowno As Long)
Dim rowcount As Long
Dim mycolumn As String
Dim c As Range
Dim mylastcell As Long
'This is to find the column where previous data
'from a worksheet has been copied to
With mywsdest.Range("A1:IV1")
Set c = .Find(ColumnHeader, LookIn:=xlValues)
If Not c Is Nothing Then
'Get the column letter
mycolumn = Split(c.Address, "$")(1)
mywsdest.Range(mycolumn & rowno).PasteSpecial xlPasteAll
Else
mylastcell = mywsdest.UsedRange.Columns.Count
If mywsdest.Range("A1").Value <> vbNullString Or mylastcell > 1 Then
mylastcell = mylastcell + 1
End If
mywsdest.Cells(1, mylastcell).Value = myws.Name
mywsdest.Cells(rowno, mylastcell).PasteSpecial xlPasteAll
End If
End With
End SubCharlize

[slamet Harto]

Dear Charlize,

I hate to bothering you, but please find the attached for your reference.
Please have a look into sheet Data2. As the result what i need is like this sheet.
I?m sorry if my question/explanation was not clear enough.

Apologize for the inconvenience cause.
Thanks a bunch.
Best rgds,
Harto

Note: Please help me again. It is difficult for me to figure out your code line per line.

[Charlize]

?Sub Gabungkan_V3()
Dim wsstart As Worksheet
Dim wsdest As Worksheet
Dim ws As Worksheet
'last row in wsstart
Dim mylastrow As Long
'last row in wsdest
Dim myrowno As Long
Set wsdest = ThisWorkbook.Worksheets("Gabungan")
For Each ws In ThisWorkbook.Worksheets
'We don't want to include Gabungan, Data?
If ws.Name <> "Gabungan" And Left(ws.Name, 4) <> "Data" Then
'I've deleted the remark/note you made on the sheet named 1
Set wsstart = ws
mylastrow = wsstart.Range("A" & Rows.Count).End(xlUp).Row
myrowno = wsdest.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
wsstart.Range("A1:A" & mylastrow).Copy
wsdest.Range("A" & myrowno).PasteSpecial xlPasteAll
End If
Next ws
Application.CutCopyMode = False
End SubCharlize

[slamet Harto]

Dear Charlize,

It is getting closer, however the code given will not possible if the data are huge.
I just modified the datas in sheet 1 and sheet 3.

Please.. please.. help me again.: pray2:

:help
thank you so much.
kind regards,
Harto

[Charlize]

Last variation on this theme. Process every column A in several worksheets in a workbook (excluding several worksheets) and copy to destination worksheet at last row from certain column and continue until the column has his maximum no of rows (if so, go on with the next column). I hope you don't have more than 256 columns. During the process, the statusbar of excel is updated to see the remainder of the copying. Don't do a thing while running this macro. Drink a cup of coffee and take a break (+/- 10 min.).
Sub Gabungkan_V5()
'The destination worksheet
Dim wsdest As Worksheet
'The worksheet that has info to copy
Dim ws As Worksheet
'myrange = range of ws = the cells in column A
'mycell = one cell of myrange
'myrowdest = the rowno where we want paste
Dim myrange As Range, mycell As Range, myrowdest As Long
'Set the destination worksheet
Set wsdest = ThisWorkbook.Worksheets("Gabungan")
'Take a look at the status bar while processing the sheets
Application.StatusBar = "Wait until everything is done ..."
'Loop through all the worksheets in a workbook
For Each ws In ThisWorkbook.Worksheets
'We don't want to include Gabungan, Data?
If ws.Name <> "Gabungan" And Left(ws.Name, 4) <> "Data" Then
'To avoid a headache, we turn screenupdating off
Application.ScreenUpdating = False
'Count the no of blank rows in column A
If WorksheetFunction.CountBlank(ws.Range("A:A")) = 65536 Then
MsgBox "Nothing to copy from worksheet : " & ws.Name
Else
MsgBox "No of items to copy : " & _
65536 - Application.WorksheetFunction.CountBlank(ws.Range("A:A")) & _
vbCrLf & "From the worksheet : " & ws.Name
'Define the area that needs to be processed
'Substract the blanks from the no of rows
Set myrange = ws.Range("A1:A" & _
(65536 - WorksheetFunction.CountBlank(ws.Range("A:A"))))
'Check on no of columns with something it it
mycolumn = wsdest.UsedRange.Columns.Count
For Each mycell In myrange
'Update statusbar with some text ...
Application.StatusBar = "Processing worksheet : " & ws.Name & " - " & _
"Copy item no : " & Split(mycell.Address, "$")(2)
mycell.Copy
'Last filled row in active column
If Application.WorksheetFunction.CountBlank(wsdest.Cells(wsdest.Rows.Count, _
mycolumn)) = 0 Then
myrowdest = 65536
Else
myrowdest = wsdest.Cells(wsdest.Rows.Count, mycolumn).End(xlUp).Row
End If
'Here we check the column
If wsdest.Cells(1, mycolumn) <> vbNullString Then
'Here we check the row
If myrowdest < 65536 Then
myrowdest = myrowdest + 1
wsdest.Cells(myrowdest, mycolumn).PasteSpecial xlPasteAll
Else
mycolumn = mycolumn + 1
wsdest.Cells(1, mycolumn).PasteSpecial xlPasteAll
End If
Else
wsdest.Cells(myrowdest, mycolumn).PasteSpecial xlPasteAll
End If
Next mycell
End If
End If
Application.ScreenUpdating = True
'Go to next worksheet
Next ws
'Turn everything back to the way it was
Application.StatusBar = ""
Application.CutCopyMode = False
End SubCharlize

[slamet Harto]

Dear Charlize,

Thank you for the code and clearly explanation. your very helpful person.

In additional, I just modified the code with this one. And luckyly it has meet my expectation.

Many Thanks for all your time, assistance and support.
With my respect.
Harto

Sub Gabungkan_V6()
Dim wsstart As Worksheet, wsdest As Worksheet, ws As Worksheet
Dim mylastrow As Long, LAST As Long
Dim myrowno As Long, myrowdest As Long
Dim MyRange As Range, mycell As Range, copyrng As Range

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Gabungan").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'add wsht
Set wsdest = ActiveWorkbook.Worksheets.Add
wsdest.Name = "Gabungan"
Set wsdest = ThisWorkbook.Worksheets("Gabungan")
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Gabungan" And Left(ws.Name, 4) <> "Data" Then
Set wsstart = ws
If WorksheetFunction.CountBlank(ws.Range("A1:IV65536")) = 16777216 Then
MsgBox "Nothing to copy from : " & ws.Name
Else
MsgBox "No of datas to copy : " & _
16777216 - Application.WorksheetFunction.CountBlank(ws.Range("A1:IV65536")) & _
vbCrLf & "From this : " & ws.Name

LAST = LastRow(wsdest)
Set copyrng = ws.Range("A1").CurrentRegion

If LAST + copyrng.Rows.Count > wsdest.Rows.Count Then
MsgBox "There are not enough rows in the dest sheet"
GoTo Finish
End If


mycolumn = wsdest.UsedRange.Columns.Count
copyrng.Copy

If Application.WorksheetFunction.CountBlank(wsdest.Cells(wsdest.Rows.Count, _
mycolumn)) = 0 Then
myrowdest = 65536
Else
myrowdest = wsdest.Cells(wsdest.Rows.Count, mycolumn).End(xlUp).Row
End If

If wsdest.Cells(1, mycolumn) <> vbNullString Then
If myrowdest < 65536 Then
myrowdest = myrowdest + 1
wsdest.Cells(myrowdest, mycolumn).PasteSpecial xlPasteAll
Else
mycolumn = mycolumn + 1
myrowdest = wsdest.Cells(wsdest.Rows.Count, mycolumn).End(xlUp).Row
wsdest.Cells(myrowdest, mycolumn).PasteSpecial xlPasteAll
Application.CutCopyMode = False
End If
Else

wsdest.Cells(myrowdest, mycolumn).PasteSpecial xlPasteAll

End If


End If


Finish:

Application.Goto wsdest.Cells(1)

'AutoFit the column width in the DestSh sheet
wsdest.Columns.AutoFit


End If

Next ws

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
End Sub
Function LastRow(ws As Worksheet)
On Error Resume Next
LastRow = ws.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function

Function LastCol(ws As Worksheet)
On Error Resume Next
LastCol = ws.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function