Info fed from various workbooks to one overview

[28creation]

Hi all,

I've got one overview workbook & several individual workbooks.

I want certain information to feed through to the overview book. I know how to do this but there's a few other bits I want to do....


I want four cells worth of information fed through from workbook #1 & the overview to have the name of workbook #1 (minus the file type) in another cell next to these four cells.

Then as info is fed into the individual workbooks the overview receives the info & adds it below the ones already received, with the name of the relevant file next to it.

Is there any way of doing this either through normal Excel means or with VBA?


Hope you can help.

Thanks, Matt

 

[AFPathfinder]

The Overview book issue can be fixed. Are you sure there is data in column B of the Team files on worksheet "Feedback Log" past row 7?

 

[28creation]

The Overview book issue can be fixed. Are you sure there is data in column B of the Team files on worksheet "Feedback Log" past row 7?

Yep, from row 8 onwards.

 

[AFPathfinder]

When you F8, is it loading the array? If it's loading the array, is it unloading the array in the coding?

This version will skip trying to open the Overview workbook:

Sub Run_Update()
    Dim mainReport As Workbook
    Dim arrEmp() As Variant
    Dim oFile As String
    Dim finalRow As Long
    Dim i As Long
    Dim n As Long
    
    Application.ScreenUpdating = False 'Turn off screen updating to speed up macro

    ReDim arrEmp(4, 0)
    
    ChDrive "P:"
    ChDir "P:\Coaching\Schemes - Denah"

    'Change this line to the directory that contains the workbooks
    oFile = Dir("P:\Coaching\Schemes - Denah\*.xlsm")

    'Load workbook object of Overview workbook into variable
    Set mainReport = Application.Workbooks("Team Overview.xlsm")

    'Find the last used row in column B and load to variable
    finalRow = Cells(Rows.Count, 2).End(xlUp).Row
    
    'Delete the old data in the Overview workbook
    If finalRow > 7 Then Range("B8:J" & finalRow).Value = ""

    'Start Looping through all files in the directory
    Do While oFile <> ""
        If Right(oFile, Len(mainReport.Name)) <> mainReport.Name Then
            Workbooks.Open Filename:=oFile, UpdateLinks:=False, ReadOnly:=True 'Open file
            Sheets("Feedback Log").Activate 'Activate the Feedback Log sheet
            finalRow = Cells(Rows.Count, Cells(8, 1).End(xlToRight).Column).End(xlUp).Row 'Find last row in column B
            If finalRow > 7 Then
                If Not arrEmp(0, 0) = "" Then
                    ReDim Preserve arrEmp(4, UBound(arrEmp, 2) + finalRow - 7) 'Expand 2nd dimension of the array to hold the new data
                End If
                For i = 8 To finalRow 'Loop through the rows
                    arrEmp(0, n) = ActiveWorkbook.Name  'Load workbook name
                    arrEmp(1, n) = Range("B" & i).Value 'Load column B data in the row to array
                    arrEmp(2, n) = Range("D" & i).Value 'Load column D data in the row to array
                    arrEmp(3, n) = Range("F" & i).Value 'Load column F data in the row to array
                    arrEmp(4, n) = Range("H" & i).Value 'Load column H data in the row to array
                    n = n + 1 'Increase the 2nd dimension counter for next row
                Next i 'Loop to next row/exit if no more rows
            End If
            ActiveWorkbook.Close SaveChanges:=False 'Close the employee workbook
        End If
        oFile = Dir
    Loop
    
    Application.ScreenUpdating = True 'Turn screen updating back on to see values being added to overview workbook
    
    n = 8 'Turn counter into row marker
    For i = LBound(arrEmp, 2) To UBound(arrEmp, 2) 'Loop through the array and unload the data to the Overview workbook row by row
        Cells(n, 2).Value = arrEmp(0, i)
        Cells(n, 4).Value = arrEmp(1, i)
        Cells(n, 6).Value = arrEmp(2, i)
        Cells(n, 8).Value = arrEmp(3, i)
        Cells(n, 10).Value = arrEmp(4, i)
        n = n + 1
    Next i
End Sub

 

[28creation]

What do you mean by "the array"?

 

[AFPathfinder]

The array is "arrEmp". In VBA, arrays are variables that can hold more than one piece of information. It's an invisible worksheet that exists in memory during the macro.

Between "For I = 8 To finalRow" and "Next i" are the lines that start adding the information to the array inside the Do Loop.

Between "For i = LBound(arrEmp, 2) To UBound(arrEmp, 2)" and "Next i" are the lines that start to transfer the data from the array to the Overview workbook.

During the F8 stepping, are the lines in those For Loops turning yellow and executing with each press of F8?

 

[28creation]

It jumps from If finalRow to End if

 

[AFPathfinder]

That means that the last value found in column B is less than row 8. Can you send me a copy of one of the individual workbooks?

 

[28creation]

I'll send it now. Thanks.

 

[28creation]

Done.

 

[AFPathfinder]

I honestly can't see where it is messing up. I've tried several configurations and they all seem to be working fine for me. I added an Else portion to the If statement to pop up when it doesn't import the values.

Sub Run_Update()
    Dim mainReport As Workbook
    Dim arrEmp() As Variant
    Dim oFile As String
    Dim finalRow As Long
    Dim i As Long
    Dim n As Long
    
    Application.ScreenUpdating = False 'Turn off screen updating to speed up macro

    ReDim arrEmp(4, 0)
    
    ChDrive "P:"
    ChDir "[COLOR=#574123]P:\Coaching\Schemes - Denah[/COLOR]"

    'Change this line to the directory that contains the workbooks
    oFile = Dir("[COLOR=#574123]P:\Coaching\Schemes - Denah[/COLOR]\*.xlsm")

    'Load workbook object of Overview workbook into variable
    Set mainReport = Application.Workbooks("Team Overview.xlsm")

    'Find the last used row in column B and load to variable
    finalRow = Cells(Rows.Count, 2).End(xlUp).Row
    
    'Delete the old data in the Overview workbook
    If finalRow > 7 Then Range("B8:J" & finalRow).Value = ""

    'Start Looping through all files in the directory
    Do While oFile <> ""
        If Right(oFile, Len(mainReport.Name)) <> mainReport.Name Then
            Workbooks.Open Filename:=oFile, UpdateLinks:=False, ReadOnly:=True 'Open file
            Sheets("Feedback Log").Activate 'Activate the Feedback Log sheet
            finalRow = Cells(Rows.Count, 2).End(xlUp).Row 'Find last row in column B
            If finalRow > 7 Then
                If Not arrEmp(0, 0) = "" Then
                    ReDim Preserve arrEmp(4, UBound(arrEmp, 2) + finalRow - 7) 'Expand 2nd dimension of the array to hold the new data
                End If
                For i = 8 To finalRow 'Loop through the rows
                    arrEmp(0, n) = ActiveWorkbook.Name  'Load workbook name
                    arrEmp(1, n) = Range("B" & i).Value 'Load column B data in the row to array
                    arrEmp(2, n) = Range("D" & i).Value 'Load column D data in the row to array
                    arrEmp(3, n) = Range("F" & i).Value 'Load column F data in the row to array
                    arrEmp(4, n) = Range("H" & i).Value 'Load column H data in the row to array
                    n = n + 1 'Increase the 2nd dimension counter for next row
                Next i 'Loop to next row/exit if no more rows
            Else
                MsgBox "Workbook " & ActiveWorkbook.Name & " is not being imported." & vbCr & "Worksheet Name: " & ActiveSheet.Name & vbCr _
                    & "Last Row in Column B: " & Cells(Rows.Count, 2).End(xlUp).Row
            End If
            ActiveWorkbook.Close SaveChanges:=False 'Close the employee workbook
        End If
        oFile = Dir
    Loop
    
    Application.ScreenUpdating = True 'Turn screen updating back on to see values being added to overview workbook
    
    n = 8 'Turn counter into row marker
    For i = LBound(arrEmp, 2) To UBound(arrEmp, 2) 'Loop through the array and unload the data to the Overview workbook row by row
        Cells(n, 2).Value = arrEmp(0, i)
        Cells(n, 4).Value = arrEmp(1, i)
        Cells(n, 6).Value = arrEmp(2, i)
        Cells(n, 8).Value = arrEmp(3, i)
        Cells(n, 10).Value = arrEmp(4, i)
        n = n + 1
    Next i
End Sub