Solved: Combine worksheets - Specifying one sheet name from multiple workbooks to combine

Good morning,

I found a kb article that provides a macro that does almost exactly what I want:

"Copies all the worksheets from all the workbooks in one folder into the active workbook."

Instead of copying all the worksheets, I would like to copy only a worksheet name I specify.

For example, if the workbooks each contained sheets Monday-Friday, I want to combine all of the Monday's into one Workbook.

Can anyone suggest a modification to the linked code to accomplish this?

Thank you very much.


edit:
I cannot post links yet so here is the code:

[VBA]
Option Explicit

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long

Public Type BrowseInfo
hOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Function GetDirectory(Optional msg) As String
On Error Resume Next
Dim bInfo As BrowseInfo
Dim path As String
Dim r As Long, x As Long, pos As Integer

'Root folder = Desktop
bInfo.pIDLRoot = 0&

'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Please select the folder of the excel files to copy."
Else
bInfo.lpszTitle = msg
End If

'Type of directory to return
bInfo.ulFlags = &H1

'Display the dialog
x = SHBrowseForFolder(bInfo)

'Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String

ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

Set Wkb = Nothing
Set LastCell = Nothing
End Sub
[/VBA]

Edit: VBA tags added to code.

Hi Waldo, welcome to the board.

Maybe something like this will work for your requirement:

[VBA]Option Explicit
Sub open_workbooks_same_folder()
Dim folder As String
Dim Wb As Workbook, sFile As String
Dim Cwb As Workbook
Dim lrow As Long
Dim iChoice As String
folder = ThisWorkbook.Path & "\"
' folder = "C:\Temp\"
Set Cwb = ThisWorkbook
sFile = Dir(folder & "*.xls")
iChoice = InputBox("Pick which Sheet to import", "Select Sheet")


Do While sFile <> ""
If sFile <> Cwb.Name Then
On Error Resume Next
Set Wb = Workbooks.Open(folder & sFile)
' Wb.Sheets("Sheet1").Copy After:=Cwb.Sheets(ThisWorkbook.Sheets.Count)
Wb.Sheets(iChoice).Copy After:=Cwb.Sheets(ThisWorkbook.Sheets.Count)
Wb.Close True
End If
sFile = Dir
Loop
Cwb.Worksheets("Data").Range("A1").Select
End Sub[/VBA]

In the attached zip are 3 files to demonstrate. Open them in the same directory although the path can be changed in the code to suit your need.

Run the runme.xls and enter a sheet name. The data files I tested on were not named monday, etc. but rather just sheet1, etc. so when the messagebox comes up just type sheet1 and hit ok.


PS. When posting code, select it and hit the vba button to format it for the forum as I did in your first post.

Lucas,

Thank you very much for the response, and for the formatting advice.

I hate to complain but no message box comes up...
I opened the first two books, and then the run me book. Excel asks if i want to enable macros, yes, and then nothing happens.

Did you intend for me to combine your code with mine?

Thank you and sorry for the clueless questions.

Are all 3 workbooks in the same directory?

Also, don't open any of them excep the runme.xls and hit the button on the sheet.

No need to combine anything. the code in the runme.xls should do what you require.

agian, leave the two data workbooks closed but in the same directory as the runme.xls.

Tried that, same result.

What version of Excel are you using. I tested in 2003

So sorry, I had the sheet in a small window. My apologies.

Works as advertised.

My next step is to consolidate all the sheets into one (all my data is identically formatted). I would use the built-in consolidation tool, VBA seems like overkill for this, no?

Again, thank you very much.

Try this Waldo. You must have one sheet named Master and it's probably case sensitive so capitalize the M.

[VBA]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
Application.DisplayAlerts = False
Sheets("Master").Delete
Application.DisplayAlerts = False
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(1)
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.Worksheets
'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[/VBA]

Lucas,

Thanks again. Unfortunately I am getting an undesired result.

I used your first macro to combine all my sheets into one. There are 20 sheets each with ~100 rows and ~50 columns. All columns are identically formatted and there are no column headers.

I created a blank sheet called Master and ran the second macro. The result was that Master was moved to the last position and three rows of data were copied (instead of the serval thousand that are available). I should add here that what I'm looking to do is append all the rows to the same sheet.

You've been so incredibly helpful already, I really appreciate it.

Thanks, Ed

Sorry Ed, I'm a little distracted with some other things here but we will figure this out.

Try this one:

[VBA]Sub Combine_Sheets()
Dim wshTemp As Worksheet, wsh As Worksheet
Dim rngArr() As Range, c As Range
Dim i As Integer
Dim j As Integer
ReDim rngArr(1 To 1)
For Each wsh In ActiveWorkbook.Worksheets
i = i + 1
If i > 1 Then ' resize array
ReDim Preserve rngArr(1 To i)
End If
On Error Resume Next
Set c = wsh.Cells.SpecialCells(xlCellTypeLastCell)
If Err = 0 Then
On Error GoTo 0
'Prevent empty rows
Do While Application.CountA(c.EntireRow) = 0 _
And c.EntireRow.Row > 1
Set c = c.Offset(-1, 0)
Loop
Set rngArr(i) = wsh.Range(wsh.Range("A1"), c)
End If
Next wsh
'Add temp.Worksheet
Set wshTemp = Sheets.Add(after:=Worksheets(Worksheets.Count))
On Error Resume Next
With wshTemp
For i = 1 To UBound(rngArr)
If i = 1 Then
Set c = .Range("A1")
Else
Set c = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)
Set c = c.Offset(2, 0).End(xlToLeft) ' skip one row
End If
'Copy-paste range (prevent empty range)
If Application.CountA(rngArr(i)) > 0 Then
rngArr(i).Copy c
End If
Next i
End With
On Error GoTo 0
Application.CutCopyMode = False ' prevent marquies
With ActiveSheet.PageSetup ' Fit to 1 page
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

Application.DisplayAlerts = False
' Sheets("Sheet1").Select
Application.DisplayAlerts = True

End Sub[/VBA]

It creates a new sheet.

Thank you! Perfect.

Really, I appreciate this very much.

Glad to help Ed. We could probably import and merge at the same time but if this is working for you then we can visit that in the future.

Be sure to mark your thread solved using the thread tools at the top of the page.

It's just a courtesy to keep people trying to offer help from reading an entire thread just to find it's been solved.

Thats great, thanks again. I will put in some elbow grease and see if I can figure out doing both, I'm sure I'll be back with questions!