PDA

View Full Version : [SOLVED] VBA Consolidate Multiple Files



hobbiton73
10-07-2013, 05:15 AM
Hi, I wonder whether someone may be able to help me please.

With a little help along the way, I'm using the code below to open mutliple workbooks, select a specific sheet and copy the data, consolidating all of the information into a 'Summary' sheet.


Sub Consolidate()

Dim DestWB As Workbook
Dim WB As Workbook
Dim ws As Worksheet
Dim SourceSheet As String
Dim StartRow As Long
Dim n As Long
Dim dr As Long
Dim LastRow As Long
Dim FileNames As Variant

Application.Calculation = xlManual

Set DestWB = ActiveWorkbook

SourceSheet = "Input"
StartRow = 2

Range("B4:I4").Select

Selection.AutoFilter

FileNames = ThisWorkbook.Worksheets("File List").Range("B4:B8").Value
For n = LBound(FileNames, 1) To UBound(FileNames, 1)

Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=ThisWorkbook.Worksheets("File List").Range("C4:C8").Cells(n).Value)
For Each ws In WB.Worksheets
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("All Data").Range("B" & DestWB.Worksheets("All Data").Rows.Count).End(xlUp).Row + 1
If dr < 4 Then dr = 4 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":I" & LastRow).Copy
DestWB.Worksheets("All Data").Cells(dr, "B").PasteSpecial xlValues
DestWB.Worksheets("All Data").Range("E4:E" & LastRow).NumberFormat = "@"
DestWB.Worksheets("All Data").Range("H4:H" & LastRow).NumberFormat = "General"
DestWB.Worksheets("All Data").Range("I4:I" & LastRow).NumberFormat = "General"
End If
End If
End With
Exit For
End If
Next ws
Application.CutCopyMode = False
WB.Close savechanges:=False

Next n
msg = MsgBox("All Clarity files have been consolidated", vbInformation)

Worksheets("All Data").Columns("B:I").AutoFit

End Sub

This piece of the script looks at column B to get the file to open and column C for the files password.


FileNames = ThisWorkbook.Worksheets("File List").Range("B4:B8").Value
For n = LBound(FileNames, 1) To UBound(FileNames, 1)

Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=ThisWorkbook.Worksheets("File List").Range("C4:C8").Cells(n).Value)


I'm having a little difficulty in running the script if only one file exists in the list. I've changed
.Range("B4:B8").Value to
.Range("B4").Value and
.Range("C4").Value to
.Range("C4").Value but when I try and run the code, I receive a 'Type mismatch' error, and despite searching for a solution online, I've been unable to fix this.

I just wondered whether someone could possibly look at this please and offer some guidance on how I may go about amending the code to cater for a dynamic file list.

Many thanks and kind regards

GTO
10-07-2013, 06:33 PM
Greetings,

Your variable 'Filenames' is declared as a Variant, which is fine as this allows Excel to sub type it (change it as necessary). When you grabbed multiple cells' values and plunked them into 'Filenames', Excel changes the variable to a 2-dimensional array. The downside is that when you changed the code to only grab one cell's value, then Excel makes 'Filenames' a Scalar (I hope I spelled that correctly) variable, that is, a variable that only holds one value. Thus, (L/U)Bound() becomes the glitch, as there is no longer an upper/lower bound. Does that make sense?

Anyways, not tried, but here's a stab:

In short, we sneak past the Workbooks.Open if there is no value (or a bad value) in one of the cell's in B Col. After turning error checking back on, we test to see if a reference was set (that is, if a workbook opened).


For n = LBound(FileNames, 1) To UBound(FileNames, 1)

On Error Resume Next
Set WB = Nothing
Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=ThisWorkbook.Worksheets("File List").Range("C4:C8").Cells(n).Value)
On Error GoTo 0

If Not WB Is Nothing Then
For Each ws In WB.Worksheets
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("All Data").Range("B" & DestWB.Worksheets("All Data").Rows.Count).End(xlUp).Row + 1
If dr < 4 Then dr = 4 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":I" & LastRow).Copy
DestWB.Worksheets("All Data").Cells(dr, "B").PasteSpecial xlValues
DestWB.Worksheets("All Data").Range("E4:E" & LastRow).NumberFormat = "@"
DestWB.Worksheets("All Data").Range("H4:H" & LastRow).NumberFormat = "General"
DestWB.Worksheets("All Data").Range("I4:I" & LastRow).NumberFormat = "General"
End If
End If
End With
Exit For
End If
Next ws
End If

Application.CutCopyMode = False
WB.Close savechanges:=False

Next n

Hope that helps,

Mark

Paul_Hossler
10-07-2013, 07:09 PM
I'd just get rid of the array, use the Range



Option Explicit
Sub test()
Dim FileNames As Range, rCell As Range
Dim FileToOpen As String
Set FileNames = ThisWorkbook.Worksheets("File List").Range("B4:B8")
For Each rCell In FileNames
FileToOpen = rCell.Value
MsgBox FileToOpen
Next


Set FileNames = ThisWorkbook.Worksheets("File List").Range("B4:B4")
For Each rCell In FileNames
FileToOpen = rCell.Value
MsgBox FileToOpen
Next
End Sub



Paul

hobbiton73
10-07-2013, 11:18 PM
Hi @GTO , thank you for taking the time to reply to my post and for putting the solution together.

I've tried the code, but unfortunatekly I receive Run-time error '91' Object variable or With block variable not set' error message. Debug highlights this line as the cause:
WB.Close savechanges:=False

Many thanks and kind regards

hobbiton73
10-08-2013, 03:20 AM
Hi @Paul, thank you very much for taking the time to reply to my post and for putting the solution together.

I'm sorry to trouble you again, but could you perhaps elaborate please and explain how I may be able to incorporate this into my existing script.

Many thanks and kind regards

Paul_Hossler
10-08-2013, 05:34 AM
Well ... I wouldn't say it was a 'solution' until it works and you like it, but maybe something like this



Option Explicit
Sub Consolidate()

Dim DestWB As Workbook
Dim WB As Workbook
Dim ws As Worksheet
Dim SourceSheet As String
Dim StartRow As Long
Dim n As Long
Dim dr As Long
Dim LastRow As Long

Dim FileNames As Range, rCell As Range '----
Dim FileToOpen As String '----

Application.Calculation = xlManual

Set DestWB = ActiveWorkbook

SourceSheet = "Input"
StartRow = 2

Range("B4:I4").Select

Selection.AutoFilter




Set FileNames = ThisWorkbook.Worksheets("File List").Range("B4:B8") '----
For Each rCell In FileNames '----

FileToOpen = rCell.Value '----

Set WB = Workbooks.Open(Filename:=FileToOpen, _
ReadOnly:=True, Password:=ReadOnly:=True, Password:=rCell.Offset(0, 1).Value)
For Each ws In WB.Worksheets
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("All Data").Range("B" & DestWB.Worksheets("All Data").Rows.Count).End(xlUp).Row + 1
If dr < 4 Then dr = 4 'destination start row
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
If LastRow >= StartRow Then
.Range("A" & StartRow & ":I" & LastRow).Copy
DestWB.Worksheets("All Data").Cells(dr, "B").PasteSpecial xlValues
DestWB.Worksheets("All Data").Range("E4:E" & LastRow).NumberFormat = "@"
DestWB.Worksheets("All Data").Range("H4:H" & LastRow).NumberFormat = "General"
DestWB.Worksheets("All Data").Range("I4:I" & LastRow).NumberFormat = "General"
End If
End If
End With
Exit For
End If
Next ws
Application.CutCopyMode = False
WB.Close savechanges:=False

Next

Call MsgBox("All Clarity files have been consolidated", vbInformation)

Worksheets("All Data").Columns("B:I").AutoFit

End Sub



Paul

Paul_Hossler
10-08-2013, 05:41 AM
WB.Saved = False


Paul

GTO
10-08-2013, 08:33 PM
ACK! Just to correct my flub.. The End If should have been below/after the WB.Close False. Sorry about that.

hobbiton73
10-10-2013, 06:04 AM
Hi @GTO, that's absolutely no problem at all, thank you very much for coming back to me with this.

Many thanks and kind regards

hobbiton73
10-10-2013, 06:06 AM
Hi @Paul Hossler, thank you very much for taking the time to put this together, it's certainly helped to illustrate the various methods which can be used and will most defitnitely help me with this and other projects I'm working on.

Many thanks and kind regards