Solved: Combining workbooks then selective worksheets

[Gil]

I am trying to combine several workbooks into one sheet. I have been successfull doing this by using the method
found in article http://vbaexpress.com/kb/getarticle.php?kb_id=221. This has been successful,No problem.
Sheets are then automatically numbered Data(1), Data(2) etc.
What I want to do now is use the method in article http://vbaexpress.com/kb/getarticle.php?kb_id=151
to combine Data (1),Data (2) etc sheets.Other sheets exist but I don't want to combine that data eg Log (1), Log (2) etc
I have already modified the following to suit my situation but I have a problem. The macro runs and stops on LN53,Col13 (Nxt sht).
If I take out the 'sht' the macro will run ok but only copies and places the data from the first sheet.
I have tried several things to no avail so I am now stuck.
Other info is that Headings are in row 1 and data in row 2. No more rows are required.

:banghead:


Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht

'We don't want screen updating
Application.ScreenUpdating = False

'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(5)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With

'We can start loop


For Each sh In Workbooks("Combine Workbooks.XLS").Windows(1).SelectedSheets
If sh.Name = "MDF Data*" Then
MsgBox "Sheet1 is selected"
Exit For
End If
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit

'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

[GTO]

Hi Gil,

Leastwise for the "thicker-heads" (namely me) an example workbook would most likely be much easier to follow. Also, when posting code, if you click on the green/white 'VBA' button before pasting, it will place tags that make it much easier to read.

Hope to help,

Mark

[lucas]

Gil, Please don't start new threads just to add vba tags to your code. You can simply edit your existing post to do same.

I have added the vba tags to your post but GTO has requested an example workbook too. Can you supply that to help get this moving?

[Gil]

Hello
Sorry about the duplication,I am trying to learn fast. Here is the attachment that Mark requested. Hope it helps.

[mdmackillop]

Alway use Option Explicit

Don't know if this gives the correct reult, but it runs!

Option Explicit
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets("MDF Data")
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop

For Each sht In wrk.Sheets
If sht.Name = "MDF Data(*)" Then
MsgBox "MDF Data(*) is selected"
Exit For
End If
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

[mdmackillop]

BTW

Dim wrk As Workbook 'Workbook object - Always good to work with object variables


Not really necessary if you are only working in one workbook, but certainly create for more than one to avoid errors in coding.

To get rid of Master without prompting

On Error Resume Next
Set sht = Sheets("Master")
Application.DisplayAlerts = False
If Not sht Is Nothing Then sht.Delete
Application.DisplayAlerts = True
On Error GoTo 0

[Gil]

To mdmackillop

Thank you for the input. It does run and gathers the data but also includes data from other sheets in the workbook. I only want to collate the MDF data I have also replaced the file as the original had hidden sheets that were not applicable for this task.

[mdmackillop]

Too late tonight. One point though, this won't work

If sht.Name = "MDF Data(*)" Then


You could try using LIKE or LEFT to compare a string.

[Gil]

Hello
I have studied other projects in the forum and am getting nowhere. I put my hands up and admit that I better not give up my day job.
I have tried Like, Left and other code but get no further. Please have a look below and point me in a direction. What is happening is that it still picks up data from other sheets in the workbook.

Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets("MDF Data")
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop

For Each sht In wrk.Sheets
If Left(sht.Name, 6) = "MDF Data" Then
MsgBox "MDF Data is selected"
Exit For
End If
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If Left(sht.Name, 6) = "MDF Data" Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

[mdmackillop]

"MDF Data" is 8 characters


If Left(sht.Name, 6) = "MDF Data" Then

[mdmackillop]

Try this

For Each Sht In wrk.Sheets
If Left(Sht.Name, 6) = "Master" Then
'do nothing
Else
Set Rng = Range(Sht.Cells(2, 1), Sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(Rng.Rows.Count, Rng.Columns.Count).Value = Rng.Value
End If
Next Sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True

[Gil]

:beerchug: Thank you to MDMACKILLOP
With the help and direction you have given I have arrived at my goal with the following Macro. I have now combined the two processes to run as one. Whether some code can be taken out I havn't tried but the whole thing works for me.

Sub TheFullMonty()

Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet

Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "d:\documents and settings\803090680\Desktop\MDF Log" 'Change as needed
FileName = Dir(Path & "\*.xls", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each WS In Wkb.Worksheets
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next WS
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets("MDF Data")
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop

For Each sht In wrk.Sheets
If Left(sht.Name, 6) = "Master" Then
'do nothing
End If

If Left(sht.Name, 8) = "MDF Data" Then
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

[Gil]

Another novice mistake by me. All is ok and I will mark as solved.