Q: Importing several similar worksheets using VBA

kterkuile

New Member
Joined
Dec 10, 2009
Messages
34
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/microsoft.public.excel.programming/browse_frm/thread/9465bfecfd35632f/762bef05490a77e5?lnk=st&q=excel+'Variable+declarations++"so+close+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

Active Member
Joined
Aug 31, 2008
Messages
310
Try this
Code:
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

New Member
Joined
Dec 10, 2009
Messages
34
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
 

Forum statistics

Threads
1,081,798
Messages
5,361,366
Members
400,628
Latest member
teresajm

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top