Pulling rows of data using VBA

What is the full path of the folder that contains the department workbooks? Are these the only files in that folder? I assume that the department workbook names contain the name of the department from the “Department” column. Can you gives us a sample department name and the name of the corresponding department workbook including the extension (xls, xlsx, xlsm)? What is the column letter of the column that contains the “Department”? Do you want to append each week's data to the bottom of the existing data in each department workbook?

To use VBA efficiently, the database should be constructed for consistency, eg. the headers will be fixed in their columns and rows and will be the same (when possible) between workbooks. This will allow rows of data to be copied from sheets in one workbook to another workbook without having to rearrange the data to accomodate headers. If you are only copying data from specific columns, as opposed to entire rows, and the data is not found in contiguous cells, but are to be pasted to cells under the same headers in the destination workbook, then the consistency in header locations will make it easier to do the copy and paste in code. That said, for yur project, assume the Department number or Name is in column A of the source workbook, the Department workbooks are named exactly as they are listedin column A of the source workbook, and sheet 1 is used for the data in both the sourc and destination workbooks. The code assumes the source workbook as host for the code. It also assumes that the directory path for all workbooks are the same.

Sub t()
Dim wb As Workbook, sh As Worksheet, c As Range, fPath As String
Set sh = ThisWorkbook.Sheets(1)
fPath = ThisWorkbook.Path
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
sh.Range("A1", sh.Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , sh.Cells(Rows.Count, 2).End(xlUp)(3), True
    For Each c In sh.sh.Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Offset(1) 'inialalize For loop in column A Unique Dept.
        If c <> "" Then 'Prevents error message for blank cells
            sh.Range("A2", sh.Cells(Row.Count, 1).End(xlUp)).AutoFilter 1, c.Value 'Filter by department
            Set wb = Workbooks.Open(fPath & c.Value & ".xlsx") 'Open department workbook assuming not macro enabled
            'copy the visible rows, excluding headers, to the next available row in destination workbook.
            sh.UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2)
            sh.AutoFilterMode = False 'turns off autofilter
            wb.Close 'close department workbook
        End If
    Next 'increment loop by one cell
sh.Cells(Rows.Count, 2).End(xlUp).CurrentRegion.ClearContents 'Clears the list of unique department names
End Sub

so if all assumtions hold, then this template would work.