asked on

related question to modify VBA, how to get it from workbooks instead of worksheets

Hi, i had a question which was answered https://www.experts-exchange.com/questions/29000556/Consolidate-multiple-worksheets-from-different-workbooks-into-single-sheet-where-columns-are-differently-structured.html

this time, i have another challenge, i was trying to figure out how to modify the the code so that instead of worksheets in thisworkbook
it prompts me to select a folder and then from folder it deletes blank worksheets and if worksheet with data found then copies the relevant data and pastes into Resultsheet of masterfile. i did not know how to modify the code. i would appreciate if someone could also comment the code so that i understand what part of the code does what. thanks very much.

Option Explicit

Sub Consolidate()
    Dim wsResult As Worksheet, ws As Worksheet
    Dim rwResultStart As Long, rwResultEnd As Long, rwSheet As Long, rwSheetMax As Long
    Dim colResult As Integer, colResultMax As Integer, col As Integer, colSheet As Integer
    
    Application.ScreenUpdating = False
    Set wsResult = ThisWorkbook.Worksheets("Result")
    If wsResult.Range("A1").CurrentRegion.Rows.Count > 1 Then
        wsResult.Range("A2", wsResult.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
    End If
    colResultMax = wsResult.Range("A1").CurrentRegion.Columns.Count
    rwResultEnd = 1
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsResult.Name And ws.Name <> "Collectionshouldlooklikethis" Then
            rwSheetMax = ws.Range("A1").CurrentRegion.Rows.Count
            rwResultStart = rwResultEnd + 1
            rwResultEnd = rwResultEnd + rwSheetMax - 1
            For colSheet = 1 To ws.Range("A1").CurrentRegion.Columns.Count
                For col = 1 To colResultMax
                    If wsResult.Cells(1, col) = ws.Cells(1, colSheet) Then
                        colResult = col
                    End If
                Next col
                For rwSheet = 2 To rwSheetMax
                    wsResult.Cells(rwResultStart + rwSheet - 2, colResult) = ws.Cells(rwSheet, colSheet)
                Next rwSheet
            Next colSheet
            wsResult.Range(Cells(rwResultStart, colResultMax), Cells(rwResultEnd, colResultMax)) = "From " & ws.Name
        End If
        
    Next ws
End Sub

Open in new window

Financial-Sample.xlsm

Ejgil Hedegaard

Try attached.
Folder selection added.
Worksheets deleted if no data.
If Header in Source sheet is not found in Result sheet, the column is skipped.
Comments added in code.

Here is the code

Option Explicit

Sub Consolidate()
    Dim wsResult As Worksheet, ws As Worksheet
    Dim rwResult As Long, rwResultStart As Long, rwResultEnd As Long, rwSheet As Long, rwSheetMax As Long
    Dim colResult As Integer, colResultMax As Integer, col As Integer, colSheet As Integer
    Dim Folder As String, fName As String, SheetsDeleted As Integer
    Dim wb As Workbook
    
    'Prevent screen flicker
    Application.ScreenUpdating = False
        
    'Select folder, uses function below
    Folder = SelectFolder("Select folder")
    If Folder = vbNullString Then
        MsgBox "No folder selected, Program Stop"
        End
    End If
    If Right(Folder, 1) <> "\" Then
        Folder = Folder + "\"
    End If
            
    'Initiate Result sheet and delete current results
    Set wsResult = ThisWorkbook.Worksheets("Result")
    If wsResult.Range("A1").CurrentRegion.Rows.Count > 1 Then
        wsResult.Range("A2", wsResult.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
    End If
    colResultMax = wsResult.Range("A1").CurrentRegion.Columns.Count
            
    'Get first Excel file in folder
    fName = Dir(Folder & "*.xlsx")
    rwResultEnd = 1
        
    'Loop files in folder
    While fName <> ""
        'Open Workbook
        Set wb = Application.Workbooks.Open(Filename:=fName)
        SheetsDeleted = 0
        'Loop sheets in workbook
        For Each ws In wb.Worksheets
            rwSheetMax = ws.Range("A1").CurrentRegion.Rows.Count
            If rwSheetMax > 1 Then
                rwResultStart = rwResultEnd + 1
                rwResultEnd = rwResultEnd + rwSheetMax - 1
                'Loop columns in Source worksheet
                For colSheet = 1 To ws.Range("A1").CurrentRegion.Columns.Count
                    'Find matching column in Result worksheet
                    colResult = 0
                    For col = 1 To colResultMax
                        If wsResult.Cells(1, col) = ws.Cells(1, colSheet) Then
                            colResult = col
                        End If
                    Next col
                    'If header found transfer data
                    If colResult > 0 Then
                        For rwSheet = 2 To rwSheetMax
                            wsResult.Cells(rwResultStart + rwSheet - 2, colResult) = ws.Cells(rwSheet, colSheet)
                        Next rwSheet
                    End If
                Next colSheet
                'Add identification to rows
                For rwResult = rwResultStart To rwResultEnd
                    wsResult.Cells(rwResult, colResultMax) = "From workbook " & wb.Name & ", worksheet " & ws.Name
                Next rwResult
            Else
                'Delete empty worksheet
                If wb.Worksheets.Count > 1 Then
                    Application.DisplayAlerts = False
                    ws.Delete
                    Application.DisplayAlerts = True
                    SheetsDeleted = 1
                End If
            End If
        Next ws
        'Save source workbook if sheet(s) has been deleted
        If SheetsDeleted = 1 Then
            wb.Save
        End If
        'Close source workbook
        wb.Close SaveChanges:=False
        'Get next file
        fName = Dir
    Wend
End Sub

Function SelectFolder(Title As String) As String
    Dim V As Variant
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = Title
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            V = vbNullString
        End If
    End With
    SelectFolder = CStr(V)
End Function

Open in new window

Financial-Sample.xlsm

Flora Edwards

ASKER

Thank you Ejgil Hedegaard.

i get the following error.

i have attached the masterfile with the source files.