VBA Find All Matches & Copy to Corresponding Tabs

[daveasu]

Working on a budget project.


I have a list of departments within our organization, and the corresponding general ledger accounts. ("Source" tab)
I need to create a worksheet for each of these in a workbook. The worksheet needs to be named Department - G/L number.


Also, I have a list of employees with their name, title, salary amounts, etc., and the general ledger number of their department.


On the salary list, I need to do a lookup in VBA that would find all the employee matches based on the G/L number, and copy/paste the employee name, salary amount, title, etc. on to the corresponding worksheet for each G/L#. (as in the examples below)


Any guidance would be much appreciated.

Source:

New tab:

 

[footoo]

Sub Add_Sheets()
Dim rng As Range, rng2 As Range, cel As Range, ws As Worksheet
Application.ScreenUpdating = False
With Sheets("Source")
    Set rng = .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp))
    Set rng2 = .Range(.[H2], .Cells(Rows.Count, "H").End(xlUp))
End With
For Each cel In rng
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = cel(1, 2) & " - " & cel
    [B2] = "Department:"
    [C2] = cel(1, 2)
    [E2] = "G/L#"
    [F2] = cel
    [B3] = "Employee"
    [C3] = "Title"
    [D3] = "Salary"
Next
For Each cel In rng2
    For Each ws In Worksheets
        If ws.Name Like "*" & cel Then
            cel(1, -2).Resize(, 3).Copy ws.Cells(Rows.Count, "B").End(xlUp)(2).Resize(, 3)
        End If
    Next
Next
For Each ws In Worksheets
     ws.[B:F].EntireColumn.AutoFit
Next
End Sub

 

[daveasu]

Footoo thank you!! This worked perfectly!

Could you tell me what command I would use to save each of the worksheets as a workbook with the same name as the worksheet?

Could I add an additional "template" sheet to each of the new workbooks as well?

Thank you again!!

 

[footoo]

Footoo thank you!! This worked perfectly!

Could you tell me what command I would use to save each of the worksheets as a workbook with the same name as the worksheet?

Could I add an additional "template" sheet to each of the new workbooks as well?

Thank you again!!

To save each sheet in a new workbook :

Sub SaveWSasWB()
Dim ws As Worksheet, wb As Workbook
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    If ws.Name <> "Source" Then
        Set wb = Workbooks.Add
        ws.Copy After:=wb.Sheets(1)
        wb.Sheets(1).Delete
        wb.SaveAs ThisWorkbook.Path & "\" & ws.Name & ".xlsx"
    End If
Next
Application.DisplayAlerts = True
End Sub

To add a "template" sheet, try the macro recorder to create the code.
Record :
Add a sheet
Re-name the sheet
Format the sheet as required

 

[daveasu]

Thank you again Footoo!

 

[daveasu]

As I'm moving further into this project, it looks like some of the Departments do not have any employees.

Is there a If/Lookup??/Then type statement that could be added to check if the G/L# in Column A was in the payroll list in Column H? And, if-not then skip to the next number in Column A?

 

[footoo]

Sub Add_Sheets()
Dim rng As Range, rng2 As Range, cel As Range, ws As Worksheet[COLOR=#ff0000], f as Range[/COLOR]
Application.ScreenUpdating = False
With Sheets("Source")
    Set rng = .Range(.[A2], .Cells(Rows.Count, "A").End(xlUp))
    Set rng2 = .Range(.[H2], .Cells(Rows.Count, "H").End(xlUp))
End With
For Each cel In rng
[COLOR=#ff0000]    Set f = rng2.Find(cel)[/COLOR]
[COLOR=#ff0000]    If Not f Is Nothing Then[/COLOR]
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = cel(1, 2) & " - " & cel
        [B2] = "Department:"
        [C2] = cel(1, 2)
        [E2] = "G/L#"
        [F2] = cel
        [B3] = "Employee"
        [C3] = "Title"
        [D3] = "Salary"
[COLOR=#ff0000]    End If[/COLOR]
Next
For Each cel In rng2
    For Each ws In Worksheets
        If ws.Name Like "*" & cel Then
            cel(1, -2).Resize(, 3).Copy ws.Cells(Rows.Count, "B").End(xlUp)(2).Resize(, 3)
        End If
    Next
Next
For Each ws In Worksheets
     ws.[B:F].EntireColumn.AutoFit
Next
End Sub