Looping through a list of employees and merging reports 1

[EliseFreedman]

Hi All

I have produced sets of 3 reports for a number of employees. These reports are stored in a folder for each employee. I now want to go through the folders and merge each set of 3 reports into a single report. To do this I am using the following code. At the moment to produce each set of reports I am selecting the employee from a cell (values using a validation list) then the reports for that employee are being merged. Can anyone tell me how to change the code so that I can get it to automatically cycle through the list of employees (B39..B60) and merge the reports for each employee.

Sub RDB_Copy_Sheet()
    Dim myFiles As Variant

    Dim myCountOfFiles As Long
        
    FolderName = Range("G39").Value
    myCountOfFiles = Get_File_Names( _
                     MyPath:="M:\depts\HS&ES\Safety\Responsible doc man Live\Elise\Exceptions\" & FolderName, _
                     Subfolders:=False, _
                     ExtStr:="*.xl*", _
                     myReturnedFiles:=myFiles)

    If myCountOfFiles = 0 Then
        MsgBox "No files that match the ExtStr in this folder"
        Exit Sub
    End If

    Get_Sheet _
            PasteAsValues:=True, _
            SourceShName:="", _
            SourceShIndex:=1, _
            myReturnedFiles:=myFiles
            

End Sub

Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _
              SourceShIndex As Integer, myReturnedFiles As Variant)
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim CalcMode As Long
    Dim SourceSh As Variant
    Dim sh As Worksheet
    Dim I As Long
    Dim myCountOfFiles As Long
FolderName = Range("G39").Value
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    On Error GoTo ExitTheSub

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)


    'Check if we use a named sheet or the index
    If SourceShName = "" Then
        SourceSh = SourceShIndex
    Else
        SourceSh = SourceShName
    End If

    'Loop through all files in the array(myFiles)
    For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(myReturnedFiles(I))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            'Set sh and check if it is a valid
            On Error Resume Next
            Set sh = mybook.Sheets(SourceSh)

            If Err.Number > 0 Then
                Err.Clear
                Set sh = Nothing
            End If
            On Error GoTo 0

            If Not sh Is Nothing Then
                sh.Copy after:=BaseWks.Parent.Sheets(BaseWks.Parent.Sheets.Count)

                On Error Resume Next
                ActiveSheet.Name = mybook.Name
                On Error GoTo 0

                If PasteAsValues = True Then
                    With ActiveSheet.UsedRange
                        .Value = .Value
                    End With
                End If

            End If
            'Close the workbook without saving
            mybook.Close savechanges:=False
        End If

        'Open the next workbook
    Next I

    ' delete the first sheet in the workbook
    Application.DisplayAlerts = False
    On Error Resume Next
    BaseWks.Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

  
  ActiveWorkbook.SaveAs "M:\depts\HS&ES\Safety\Responsible doc man Live\Elise\Exceptions\ExceptionsReports\" & "ExceptionsFor" & FolderName & ".xls"

ActiveWorkbook.Close
ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub

 

[SkipVought]

hi,

I have produced sets of 3 reports for a number of employees.

If you did THAT, presumably from a data source that has ALL the data for ALL the employees, isn't that data source, a better source for this task, than your spawned reports?

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[macropod]

hi Elise,

You could re-code your RDB_Copy_Sheet sub as:
Dim FolderName As String
Const StrPath As String = "M:\depts\HS&ES\Safety\Responsible doc man Live\Elise\Exceptions\"

Sub RDB_Copy_Sheet()
Dim myFiles As Variant, myCountOfFiles As Long, I As Long
For I = 39 To 60
FolderName = Range("G" & I).Value
myCountOfFiles = Get_File_Names(MyPath:=StrPath & FolderName, Subfolders:=False, ExtStr:="*.xl*", myReturnedFiles:=myFiles)
If myCountOfFiles = 0 Then
MsgBox "No files that match the ExtStr in this folder"
Exit Sub
End If
Get_Sheet PasteAsValues:=True, SourceShName:="", SourceShIndex:=1, myReturnedFiles:=myFiles
Next
End Sub
(note the new variables outside the sub)
You can then delete the 'FolderName = Range("G39").Value' line from your 'Get_Sheet' sub and change the 'SaveAs line to:
ActiveWorkbook.SaveAs StrPath & "\ExceptionsReports\ExceptionsFor" & FolderName & ".xls"

Cheers
Paul Edstein
[MS MVP - Word]