Excel VBA multiple loops to output data to individual worksheets

[nvdunn]

HI there I was wondering if someone can please help me.
I have a services report that is generated every 6 months to capture whether service was delivered to the customer. I am trying to automate a manual process of outputting the results of undelivered service to the person's manager.
I have my loops working but am running into problems trying to work out whether the output has been done for the particular client.
I am wanting to loop through each row (there's 10,000 rows) and find the manager name and output all staff members that report to that manager on the next worksheet (The data is listed by staff member). Then save and output the data to the designated directory.
I works if all my managers are listed in a neat order however this won't always be the case and there will often be blanks or #N/As that i want to allow for.

if anyone has any suggestions for my loops it would be greatly appreciated

Please see attached for a report with dummy data that i'm trying to get working.
Many thanks for your help

Sub routine VBA code i am using is:
--------------------------------------------
Sub Export_UnflaggedServices()


Dim strDate As String
Dim strOutputDir As String
Dim lLastRow As Long
Dim lLastRowOutputs As Long 'Find last row in data once it's saved to new workbook so can clear data
Dim strFPM As String 'Sort by Manager and loop through each row searching for manager to output to new worksheet
Dim strFPMOutput As String 'Output area
Dim strOutputFname 'new file name you want to output tp
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim strWBFPMFile As String
Dim bolFPMOutput As Boolean 'Flag to identify if Manager has been outputted

Application.ScreenUpdating = False
On Error GoTo ErrHandler


strDate = Application.Worksheets("UI").Range("Date").Value
strOutputDir = Application.Worksheets("UI").Range("OutputDir").Value
strWBFPMFile = Application.ActiveWorkbook.Name

'Call Copy_FDS_Data ' Import FDS Unflagged Services report.


Application.Worksheets("FDS").Activate 'Copy headers back into export template if they are missing
Range("A1:I1").Select
Selection.Copy
Application.Worksheets("FDSReport").Activate
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.ActiveWorkbook.Save

Application.Worksheets("FDS").Activate
lLastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
k = 2 'Counting row for Report output
bolFPMOutput = False




For i = 2 To lLastRow
bolFPMOutput = Application.Worksheets("FDS").Cells(i, 9) 'Search on first loop through to see if already has been outputted

If bolFPMOutput = True Then
GoTo ErrHandler
'Exit For 'need to work out how to skip to next row for j if outputted already
End If

'2nd Loop
For j = 2 To lLastRow 'Starting at row 2 of data (take into account headers)
strFPM = Application.Worksheets("FDS").Cells(i, 8) 'Read in name of Manager
strFPMOutput = Application.Worksheets("FDS").Cells(j, 8) 'output Manager name
bolFPMOutput = Application.Worksheets("FDS").Cells(j, 9)
'Application.Worksheets("FDS").Activate

If bolFPMOutput = True Then
GoTo ErrHandler
'Exit For 'need to work out how to skip to next row for j if outputted already
End If



If IsError(strFPM) Then
'do nothing and skip to next i
End If



If strFPM = strFPMOutput Then 'Match on manager name and copy temp s/s FDSReport
bolFPMOutput = True
Application.ActiveSheet.Cells(j, 9) = bolFPMOutput
Range(Cells(j, 1), Cells(j, 11)).Select
Selection.Copy
Application.Worksheets("FDSReport").Activate
ActiveSheet.Cells(k, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
k = k + 1 'Add 1 to the counter to go to the next row to output data
End If


Application.Worksheets("FDS").Activate
bolFPMOutput = False 'resetting back to false for next loop
Next j





strOutputFname = strOutputDir & "" & strDate & " " & " " & "FDSReport" & " " & strFPM & ".xlsx"

Application.Worksheets("FDSReport").Activate
ActiveSheet.Copy



ActiveWorkbook.SaveAs (strOutputFname)
ActiveWorkbook.Close
Application.Workbooks(strWBFPMFile).Activate
Application.Worksheets("FDSReport").Activate
lLastRowOutputs = Sheets("FDSReport").Range("A" & Rows.Count).End(xlUp).Row

Range("A2:J" & lLastRowOutputs).Clear 'Clear out existing client data but preserve header
Application.Worksheets("FDS").Activate

ErrHandler:
'strFPM = ""
'strFPM.Value = Error
Resume Next

'bolFPMOutput = False 'resetting back to false for next loop
Next i


MsgBox "FDS Unflagged Services have been run and saved " & strOutputDir

Application.ScreenUpdating = True


End Sub
--------------------------------------------------------------------------
For some reason i cannot upload my spreadsheet but here is what it looks like:

worksheet1: FDS

ClientID	Clientname	StaffID	Staff Name	ServiceName	IsProvided	Reason	Manager	Outputted
12345	Terry Hoppy	11111111	John Smith	Phone call	0	NULL	Hall, Karen	TRUE
76661	ELVA ROSE	22222222	Shane Hall	Meeting	0	NULL	Hall, Karen
12345	DAVID LI	33333333	Shane Hall	Review	0	NULL	Hall, Karen
161305	JOHN RYAN	44444444	Ian Smith	Review	0	NULL	Verra ,Anna
106067	DAVID LION	55555555	Shane Hall	Meeting	0	NULL	Hall, Karen
184626	MARGARET RUDD	66666666	Heather Run	Review	0	NULL	Hall, Karen
193470	MARGARET RUDD	7777777	Heather Run	Phone call	0	NULL	Hall, Karen
163841	PAMELA WOODS	8888888	Lucas Neil	Meeting	0	NULL	Smith, Warren
108014	PAMELA WOODS	9999999	Lucas Neil	Review	0	NULL	Smith, Warren
142331	WAYNE KEITH	1010101	Lucas Neil	Phone call	0	NULL	Smith, Warren
108559	WAYNE KEITH	11112222	Lucas Neil	Meeting	0	NULL	Smith, Warren
151489	ANDREW CONSTANT	11233454	Anita Bradley	Review	0	NULL	#N/A
76661	ELVA BARKER	2323323	Shane Hall	Meeting	0	NULL	Hall, Karen
119213	SHIRLEY PLOOG	4566778	Simon Johns	Meeting	0	NULL	Call, Mark

<tbody>
</tbody>

 

[JLGWhiz]

see if this will get you closer to where you want to go.

Sub makeSheets2()
Dim lr As Long, sh As Worksheet
lr = Sheets("FDS").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("FDS")
    .Range("H1", .Cells(Rows.Count, 8).End(xlUp)).AdvancedFilter xlFilterCopy, , Range("B" & lr + 2), True
    Set rng = .Range("B" & lr + 2).CurrentRegion
        For i = 2 To rng.Cells.Count - 1
            Sheets.Add After:=Sheets("FDS")
            Set sh = ActiveSheet
            sh.Name = rng.Cells(i).Value
            .Range("A1:I" & lr).AutoFilter 8, rng.Cells(i).Value
            .Range("H2:H" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy sh.Range("A2")
            .Rows(1).Copy sh.Range("A1")
            Set sh = Nothing
        Next
    .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Delete xlShiftUp
End With
End Sub

feel free to modify to your needs.

 

[nvdunn]

see if this will get you closer to where you want to go.

Sub makeSheets2()
Dim lr As Long, sh As Worksheet
lr = Sheets("FDS").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("FDS")
    .Range("H1", .Cells(Rows.Count, 8).End(xlUp)).AdvancedFilter xlFilterCopy, , Range("B" & lr + 2), True
    Set rng = .Range("B" & lr + 2).CurrentRegion
        For i = 2 To rng.Cells.Count - 1
            Sheets.Add After:=Sheets("FDS")
            Set sh = ActiveSheet
            sh.Name = rng.Cells(i).Value
            .Range("A1:I" & lr).AutoFilter 8, rng.Cells(i).Value
            .Range("H2:H" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy sh.Range("A2")
            .Rows(1).Copy sh.Range("A1")
            Set sh = Nothing
        Next
    .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Delete xlShiftUp
End With
End Sub

feel free to modify to your needs.

Thanks so much for your help. Very much appreciated. I will modify but can make this work. Many thanks

 

[JLGWhiz]

Thanks so much for your help. Very much appreciated. I will modify but can make this work. Many thanks

You're welcome,
regards, JLG