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
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