Q: Importing several similar worksheets using VBA

[kterkuile]

Hi all,

I have a number of workbooks that are in the same map. These workbooks consist of one workmap only. All of these workmaps have the same layout. In it are production data for monitoring the quality of several production processess (one workbook per proces). The first two rows have the caprions for the columns below. These captions are the same and in the same position as in every other workbook in this map.

I want to

1. copy all the data from the workbooks to a main workbook on the same page in the main workbook
2. copy the caption once and paste the results below, each worksheet under the other

Now, i stumbled on this thread: http://www.mrexcel.com/forum/showthread.php?t=83597&page=1, very very helpful (as well as a defenitive 'don't' in netiquette) and the reworked code from that thread on http://groups.google.com/group/micr...ose+yet+so+far"&rnum=1&hl=en#762bef05490a77e5. Tom Urtis and Dave Peterson are kings in my book!

Now here's my problem

1. I'm a VBA n00b
2. the code almost does what i need, but not entirely

The code does wonderful work opening files and copying worksheets to a main worksheet, however when it pastes the results from the workbooks it leaves out the last row of every worksheet and/or pastes the results of each worksheet over the last row of it's predecessor.

Could any one of you help me out, please? I would really appreciate the help. The code is below.

Karel ter Kuile


Option Explicit
Sub ImportDistricts2()

'Variable declarations
Dim NextRow As Long
Dim LastRow As Long
Dim wkbk As Workbook
Dim NeedHeaders As Boolean
Dim wks As Worksheet
Dim fCtr As Integer
Dim myFileNames As Variant

'Instructional Message Box
MsgBox "Click OK to access the Open dialog." & vbCrLf & _
"Navigate to the folder path that contains" & vbCrLf & _
"the District workbooks you want to import." & vbCrLf & vbCrLf & _
"When you get inside that folder path," & vbCrLf & _
"use your mouse to select one workbook," & vbCrLf & _
"or use the Ctrl button with your mouse" & vbCrLf & _
"to select as many District workbooks" & vbCrLf & _
"as you want from that same folder path." & vbCrLf & vbCrLf & _
"There is a limit of one path per macro run," & vbCrLf & _
"but as many workbooks per path as you want." & vbCrLf & vbCrLf & _
"Please click OK to get started.", 64, "Instructions..."

myFileNames = Application.GetOpenFilename _
(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)

If IsArray(myFileNames) Then
'ok to keep going
Else
MsgBox "You did not select any workbooks." & vbCrLf & _
"Click OK to exit this macro.", 48, "Import action cancelled."
Exit Sub
End If

'Prepare Excel
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Open loop for action to be taken on all selected workbooks.
For fCtr = LBound(myFileNames) To UBound(myFileNames)
'Open the workbook(s) that were selected.
Set wkbk = Workbooks.Open(Filename:=myFileNames(fCtr))
'Open loop to act on every sheet.
For Each wks In wkbk.Worksheets
Application.StatusBar = "Processing " & wks.Name & " in " _
& myFileNames(fCtr)
'Determine if the sheet name in the District workbook also
'exists in the Main workbook.
'If not, create one in the Main workbook.
'If so, disregard and move on.
If WorksheetExists(wks.Name, ThisWorkbook) Then
'do nothing
Else
With ThisWorkbook
.Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = wks.Name
End With
End If

'At this point we know there is a sheet name in the Main workbook
'for every sheet name in the District workbook, which will remain
'unique, not duplicated.
'Determine the next available row in the Main workbook for this
'particular sheet in the District workbook.
'If structures are to guard against run time error if
'sheet(s) is / are blank.

With wks
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With ThisWorkbook.Worksheets(wks.Name)
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row
NeedHeaders = False
If NextRow = 1 Then
If IsEmpty(.Cells(1, "A")) Then
NeedHeaders = True
End If
NextRow = 2
End If
End With

'Copy the rows from the District sheet to the Main
'workbook's sheet whose name is the same.
If NeedHeaders = True Then
wks.Rows(1).Copy _
Destination:=ThisWorkbook.Worksheets(wks.Name).Range("a1")
End If

wks.Rows("2:" & LastRow).Copy _
Destination:=ThisWorkbook.Worksheets(wks.Name).Cells(NextRow, 1)

'Continue and terminate the loop for all worksheets in the
'District workbook.
Next wks
'Close the District workbook without saving it.
wkbk.Close savechanges:=False
'Continue and terminate the loop for the selected District workbooks.
Next fCtr

'Restore Excel.
With Application
.ScreenUpdating = True
.EnableEvents = True
.StatusBar = False
End With

'Message box to inform user the job is complete.
MsgBox "The import is complete.", 64, "Done !!"
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = Len(WB.Worksheets(SheetName).Name) > 0
End Function

 

[rassten]

Try this

Option Explicit
Sub ImportDistricts2()

'Variable declarations
Dim NextRow As Long
Dim LastRow As Long
Dim wkbk As Workbook
Dim NeedHeaders As Boolean
Dim wks As Worksheet
Dim fCtr As Integer
Dim myFileNames As Variant

'Instructional Message Box
MsgBox "Click OK to access the Open dialog." & vbCrLf & _
"Navigate to the folder path that contains" & vbCrLf & _
"the District workbooks you want to import." & vbCrLf & vbCrLf & _
"When you get inside that folder path," & vbCrLf & _
"use your mouse to select one workbook," & vbCrLf & _
"or use the Ctrl button with your mouse" & vbCrLf & _
"to select as many District workbooks" & vbCrLf & _
"as you want from that same folder path." & vbCrLf & vbCrLf & _
"There is a limit of one path per macro run," & vbCrLf & _
"but as many workbooks per path as you want." & vbCrLf & vbCrLf & _
"Please click OK to get started.", 64, "Instructions..."

myFileNames = Application.GetOpenFilename _
(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)

If IsArray(myFileNames) Then
'ok to keep going
Else
MsgBox "You did not select any workbooks." & vbCrLf & _
"Click OK to exit this macro.", 48, "Import action cancelled."
Exit Sub
End If

'Prepare Excel
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Open loop for action to be taken on all selected workbooks.
For fCtr = LBound(myFileNames) To UBound(myFileNames)
'Open the workbook(s) that were selected.
Set wkbk = Workbooks.Open(Filename:=myFileNames(fCtr))
'Open loop to act on every sheet.
For Each wks In wkbk.Worksheets
Application.StatusBar = "Processing " & wks.Name & " in " _
& myFileNames(fCtr)
'Determine if the sheet name in the District workbook also
'exists in the Main workbook.
'If not, create one in the Main workbook.
'If so, disregard and move on.
If WorksheetExists(wks.Name, ThisWorkbook) Then
'do nothing
Else
With ThisWorkbook
.Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = wks.Name
End With
End If

'At this point we know there is a sheet name in the Main workbook
'for every sheet name in the District workbook, which will remain
'unique, not duplicated.
'Determine the next available row in the Main workbook for this
'particular sheet in the District workbook.
'If structures are to guard against run time error if
'sheet(s) is / are blank.

With wks
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With ThisWorkbook.Worksheets(wks.Name)
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row
NeedHeaders = False
If NextRow = 1 Then
If IsEmpty(.Cells(1, "A")) Then
NeedHeaders = True
End If
NextRow = 2
End If
End With

'Copy the rows from the District sheet to the Main
'workbook's sheet whose name is the same.
If NeedHeaders = True Then
wks.Rows(1).Copy _
Destination:=ThisWorkbook.Worksheets(wks.Name).Range("a1")
End If

wks.Rows("2:" & LastRow).Copy _
Destination:=ThisWorkbook.Worksheets(wks.Name).Cells(NextRow + 1, 1)

'Continue and terminate the loop for all worksheets in the
'District workbook.
Next wks
'Close the District workbook without saving it.
wkbk.Close savechanges:=False
'Continue and terminate the loop for the selected District workbooks.
Next fCtr

'Restore Excel.
With Application
.ScreenUpdating = True
.EnableEvents = True
.StatusBar = False
End With

'Message box to inform user the job is complete.
MsgBox "The import is complete.", 64, "Done !!"
End Sub
Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = Len(WB.Worksheets(SheetName).Name) > 0
End Function

 

[kterkuile]

Try this

Thank you so much for your speedy answer, Sten. I quickly scanned it and i see you added '+1', that's all, isn't it. I can kick myself for not getting that! Anyway, thank you so much for helping me out more than you'll ever know. I'll try the solution of wednesday and i'll let you know how it works out. Bye for now,

Karel

 

[kterkuile]

I'll try the solution of wednesday and i'll let you know how it works out.

@ Sten,

It workes! IT WORKS! Thanks again Sten; you really, really helped me out.

Take care,

Karel