Excel VBA multiple loops to output data to individual worksheets

N

nvdunn

New Member
Joined
Nov 4, 2015
Messages
12
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

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

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
see if this will get you closer to where you want to go.

Code: 
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.
 
Last edited:
Upvote 0
JLGWhiz said:
see if this will get you closer to where you want to go.

Code: 
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.
Click to expand...

Thanks so much for your help. Very much appreciated. I will modify but can make this work. Many thanks :)
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
124
sijpie
sijpie
C
  • Question Question
Loop validation, copy output from same range and paste in different ranges
Replies
1
Views
691
RoryA
RoryA
N
  • Solved
Excel 2016 VBA - Pull data from multiple sheets to One with specificities
Replies
3
Views
250
mumps
mumps
S
  • Question Question
Using VBA to Flag and Calculate Overlapping Shift Times
Replies
0
Views
452
Snort
S
A
  • Question Question
Import Table Data from Web using VBA to excel Worksheet and able to input Values which can modify the web data to be extract
Replies
0
Views
635
Ambrosia
A

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top