VBA Consolidate Multiple Files

[hobbiton73]

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]

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]

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]

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]

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]

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]

WB.Saved = False

Paul

[GTO]

ACK! Just to correct my flub.. The End If should have been below/after the WB.Close False. Sorry about that.

[hobbiton73]

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]

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