Re: So close yet so far - combining workbooks
Dave Peterson
on. And your post's format got justified to the left and a few dots were lost.
Variable names that are w,x,y,z may mean something to you, but they're usually
confusing to me. I changed some of your variable names (I find calling
something NextRow is easier than Tlr).
Also, I changed a couple of error checks. The biggest was including a nice
function from Chip Pearson that will tell you if a worksheet exists. By using a
function, it makes the primary code easier to understand (less of an
interruption of thought(?) when you're reviewing the code).
I also got rid of the way you found the last row. (.cells.find()). I think you
may have had an error by using [a1] as a reference. That refers to the
activesheet and you're not always looking at the activesheet.
Try this against a test workbook with multiple sheets:
Dim wks As Worksheet
For Each wks In Worksheets
MsgBox [a1].Address(external:=True)
Next wks
You'll always get the same result.
Well, anyway try this version to see if it's closer to what you need. It worked
ok for me in simple tests...
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
"happy <" wrote:
>
> Hi,
>
> I am newbie to this board and I am having a major problem. I want to
> combine 15 workbooks to a main workbook. The main workbook looks just
> like the 15 workbooks except that it has blank rows that will be filled
> in from the other workbooks. Each worksheet has a header row and the
> first row where the data is entered is different on each worksheet. I
> have received a code from someone that does somewhat what I am looking
> for *but* it also brings in the header rows from each worksheet and it
> does not populate to the empty rows in the Main Workbook. So for
> example if I have worksheet named Hardlines in the Main Workbook after
> selecting the files I want it to populate to row 2, then row 3 etc.
> Also I have a multi select box, and shapes on each worksheet. These do
> not need to be imported to the Main Workbook since it is already exist.
> Below you will find my code that someone helped me with. But I am new
> at coding so I don't know how to add new coding to it.
>
> I appreciate your help and I am sorry about the length of this
> message.
>
> Here is my code:
>
> Sub ImportDistricts2()
> '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..."
> 'Variable declarations
> Dim Tlr As Long, Alr As Long, u As String, v As String, w As Worksheet,
> x As Integer, y As Integer, z As Variant
> z = Application.GetOpenFilename(FileFilter:="Excel files (*.xls),
> *.xls", MultiSelect:=True)
> 'Prepare Excel
> With Application
> ScreenUpdating = False
> EnableEvents = False
> End With
> 'Open loop for action to be taken on all selected workbooks.
> On Error Resume Next
> For x = 1 To UBound(z)
> 'Error handler within code if Cancel is clicked in Open dialog.
> If Err.Number = 13 Then
> With Application
> ScreenUpdating = True
> EnableEvents = True
> End With
> MsgBox "You did not select any workbooks." & vbCrLf & _
> "Click OK to exit this macro.", 48, "Import action cancelled."
> On Error GoTo 0
> Err.Clear
> Exit Sub
> End If
> 'Open the workbook(s) that were selected.
> Workbooks.Open (z(x))
> 'Open loop to act on every sheet.
> For Each w In ActiveWorkbook.Worksheets
> 'Identify sheet name
> v = w.Name
> '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.
>
> Err.Clear
> On Error Resume Next
> u = ThisWorkbook.Worksheets(v).Name
> If Err.Number <> 0 Then
> With ThisWorkbook
> Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = v
> End With
> End If
> On Error GoTo 0
> Err.Clear
> '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.
> If Application.CountA(w.Columns(1)) = 1 Then
> Alr = 2
> Else
> Alr = w.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows,
> SearchDirection:=xlPrevious).Row
> End If
> If Application.CountA(ThisWorkbook.Worksheets(v).Cells) <> 0 Then
> Tlr = ThisWorkbook.Worksheets(v).Cells.Find(What:="*", After:=[A1],
> SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
> Else
> Tlr = 1
> End If
> 'Copy the rows from the District sheet to the Main workbook's sheet
> whose name is the same.
> w.Rows("2:" & Alr).Copy ThisWorkbook.Worksheets(v).Cells(Tlr, 1)
> 'Continue and terminate the loop for all worksheets in the District
> workbook.
> Next w
> 'Close the District workbook without saving it.
> ActiveWorkbook.Close False
> 'Continue and terminate the loop for the selected District workbooks.
> Next x
> 'Restore Excel.
> With Application
> ScreenUpdating = True
> EnableEvents = True
> End With
> 'Message box to inform user the job is complete.
> MsgBox "The import is complete.", 64, "Done !!"
> End Sub
> :confused: :confused: :confused:
>
> ---
> Message posted from http://www.ExcelForum.com/
--
Dave Peterson
ec3...@msn.com
Dave Peterson
Can you give a list? And if the sheet isn't on that list, what do you do?
Look for the "select case" statement added in the code. Modify that to include
all your sheet names. Use the "case else" for the most common number of
headerrows--so you don't have to type all the worksheet names that use that
number.
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
Dim HeaderRows As Long
Select Case LCase(wks.Name)
Case Is = "sheet1": HeaderRows = 1
Case Is = "sheet2": HeaderRows = 7
Case Is = "sheet3": HeaderRows = 12
Case Else
HeaderRows = 2
End Select
'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 & ":" & HeaderRows).Copy _
Destination:=ThisWorkbook.Worksheets(wks.Name).Range("a1")
End If
wks.Rows(HeaderRows + 1 & ":" & LastRow).Copy _
Destination:=ThisWorkbook.Worksheets(wks.Name).Cells(NextRow, 1)
"happy <" wrote:
>
> And so the saga continues,
>
> It is working!! I figured out the what the error message was, but now
> what I need to do is assign a range for each sheet. Because each sheet
> begins on a different row. For example on one sheet it begins on A2
> and another one it begins on A7. So now here is my latest request is
> there a way to assign each sheet a range in this code??
> Many Many Many thanks you guys rock!!
Dave Peterson
It looks at each row in each of those ranges (A8:h17, a22:h31, A36:h46) for
example. If that row isn't used (counta()= 0), then it doesn't copy that row.
I'm not sure how the headers should work, but I took a guess.
Try it against a copy of your workbook--it may do stuff that I didn't understand
and that you didn't want.
Option Explicit
Sub ImportDistricts2()
'Variable declarations
Dim NextRow As Long
Dim wkbk As Workbook
Dim wks As Worksheet
Dim fCtr As Integer
Dim myFileNames As Variant
Dim myAddr As Variant
Dim aCtr As Long
Dim myRow As Range
Select Case LCase(wks.Name)
Case Is = "hardlines"
myAddr = Array("A8:H17", "A22:H31", "A36:H46")
Case Is = "softlines-teamsports"
myAddr = Array("a8:G17", "A23:G33", "A36:G46")
Case Is = "footwear merchandise"
myAddr = Array("A8:G18", "A22:G22")
Case Is = "pricing"
myAddr = Array("A12:G22")
Case Is = "advertising"
myAddr = Array("A12:G22", "A26:G26")
Case Is = "operational"
myAddr = Array("a8:f18")
Case Is = "distribution center"
myAddr = Array("a8:F18")
Case Is = "is issues"
myAddr = Array("A11:G21")
Case Is = "construction and visual"
myAddr = Array("A8:F18")
Case Is = "competition"
myAddr = Array("a8:h18")
Case Is = "real estate"
myAddr = Array("A8:F18")
Case Else
myAddr = Array("a10:f20")
End Select
For aCtr = LBound(myAddr) To UBound(myAddr)
For Each myRow In wks.Range(myAddr(aCtr)).Rows
If Application.CountA(myRow) = 0 Then
'do nothing
Else
With ThisWorkbook.Worksheets(wks.Name)
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If aCtr = LBound(myAddr) Then
If NextRow < _
wks.Range(myAddr(aCtr)).Rows.Count Then
wks.Range("1:" _
& wks.Range(myAddr(aCtr)).Row - 1).Copy _
Destination:=.Range("a1")
NextRow _
= wks.Range(myAddr(aCtr)).Rows.Count + 1
End If
End If
myRow.Copy _
Destination:=ThisWorkbook.Worksheets(wks.Name) _
.Cells(NextRow, "A")
NextRow = NextRow + 1
End With
End If
Next myRow
Next aCtr
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
"happy <" wrote:
>
> Thank you for getting back to me.
>
> OK what I have done is outline each sheet name and their range where
> the user will be entering their information. The ranges are the only
> area where I need to capture. The Main workbook is identical to this
> except there are blank lines for the information to go to.
>
> "Hardlines" (A8:H17);(A22:H31);(A36:H46)
> "Softlines-TeamSports" (A8:G17);(A23:G33);(A36:G46)
> "Footwear Merchandise"(A8:G18);(A22:G22)
> "Pricing" range (A12:G22)
> "Advertising" range (A12:G22);(A26:G26)
> "Operational" range (A8:F18)
> "Distribution Center" (A8:F18)
> "IS Issues" range (A11:G21)
> "Construction and Visual" (A8:F18)
> "Competition" (A8:H18)
> "Real Estate" (A8:F18)
> "Other" (A10:F20)
>
> As you can see there are some duplications so if I have a sheet with
> three header rows do I just count from the top when using case else?
> I hope I am on the right track.
>
> Also just one more question, if a worksheet doesn't have any data or
> there are blank rows is it possible to add this to the code so the
> blank informatin doesn't come over. It is currently happening in the
> code now.
>
> You don't know how much I appreciate your help. I am looking forward
> to hearing your answer.
Dave Peterson
And this is a text newsgroup. Most people (me included) don't open attachments
and don't want to see large posts. (It's not fair to people who pay for
internet access by the minute (still in Europe????) or for people who use dialup
access (me!).)
For hardlines only, you gave 3 ranges:
A8:H17, A22:H31, A36:H46
The code I gave looks at each row in each range looking to see if it was used.
If not, it skips that row.
If that row was used, it copies it to the combined "hardlines" worksheet. It
uses column A to determine the next available row.
If that's not what's supposed to happen, please describe it again.
(maybe a8:h17 is one block--all gets copied or none gets copied???)
"happy <" wrote:
>
> Dave if you are there it is me again.....
>
> I tried the code again and it is working to an extent. For example, if
> I have information on Row A8 on my "other" page it brings it down 3
> rows. Or if I have information on the Hardlines page in the first
> section it brings the information down to the last section. I hope
> that this is clear, if not let me know and I can send a snapshot of
> what is happening.
>
> Thanks again for your help.
Dave Peterson
Can you skinny down your master workbook and an imported one. Try to make it
small (zip it).
And send it to my email address--not the newsgroup.
In fact, if you included a version of what the hardlines worksheet should be in
the master, I can compare and see what I'm doing wrong.
Please skinny it down, though. I'm on a dialup.
(And it's past my bedtime and there's work tomorrow. So it might be a few hours
before I can even open it.)
"happy <" wrote:
>
> Soffy if it sounded a little confusing, but your understanding of what
> is suppose to happen is right on track but for some reason when the
> file is imported it is doing something totally differnt. If on the
> "hardlines" worksheet I have data in rows A8, A9, and A10 and nothing
> else on the worksheet, it will populate to rows A36,A37, and A38 on the
> Main Worksheet. Or on the "other" worksheet I had information on rows
> A8 and A10 and it populated to rows A13 and A14.
>
> I hope this clears things up and once again I appreciate your help.
>
> Thank you
Dave Peterson
the worksheet and removed the existing data (except for the portion that is used
to receive the data).
Did you not get that?
"happy <" wrote:
>
> Sorry I haven't gotten back to you sooner, but I am still having some
> issues. The good news is that it will import the information to all
> the spreadsheets. The bad news is that it still imports the Headers
> only on 6 of the workseets. Which are after the first 4 and before the
> last 4 worksheets of the 14 worksheets. Now on the 6 worksheets the
> headers are coming from the worksheets being imported and placed above
> the original header in the Main Workbook.
>
> Does it make sense to have several case statements based on the amount
> of headers per sheet.
> So for example,
>
> First Case Statement could be for Hardlines, (with 5 headers)
>
> Second Case Statement could be for Softlines (3 Headers)
>
> Third Case Statement could be for Footwear Merchandise, Advertising (2
> Headers)
>
> Final Case Statement would be for the remainder worksheets with 1
> header.
>
> I hope this makes sense to you. I really appreciate the time you have
> put into it to make this work.
Dave Peterson
If WorksheetExists(wks.Name, ThisWorkbook) Then
'do nothing
Else
With ThisWorkbook
'get headers and all the layout
wks.Copy _
after:=.Sheets(.Sheets.Count)
'clean any data in that existing sheet
'so that empty rows can be avoided
With .Worksheets(wks.Name)
For aCtr = LBound(myAddr) To UBound(myAddr)
.Range(myAddr).ClearContents
Next aCtr
End With
End With
End If
copies headers--in fact, it copies the whole worksheet if it didn't exist in the
receiving workbook.
Are you sure the worksheet has headers?
"happy <" wrote:
>
> Thanks for your reply,
>
> I did get your code but it is still not working probably. It still
> seems to import headers only on 6 worksheets. If you would like I can
> send you the code via private email.
>
> Please advise,
>
> Happy