Loop through Data Validation list in Advanced Filter Copy Paste all Results on one sheet

jsepanski

New Member
Joined
Oct 2, 2019
Messages
7
I am having an issue with looping through my advanced filter that loops through a data validation list then needs to copy each filtered data result into one sheet, one after another. I am able to get the data validation to loop through each drop down selection and filtered each persons results but it was copying and pasting the results into new workbooks for each drop down selection. So I was getting 15 new workbooks. I am not able to get it to paste into a sheet that I created in my workbook titled "Template" I can only get the first selection off the drop down list to paste in and then it errors out or stops. I am running the data validation list from a "Dashboard tab" that filters through an advanced filter criteria then populates the data in a table below the criteria range. This is the data that I need to copy and paste values into the template sheet for each person in the drop down list for the selected supervisor one below the other for one complete list. I only need the results copied from the range starting at B83 as I have the headers on my template sheet.

Is there a way to copy all results to one sheet. Do I need to clear out the filtered table result before it loops through the next person?

Sub SupLook()
'
' Looping Macro
'
Dim FName As String
FName = Sheets("Dashboard").Range("B80").Text

Dim FolderName As String
Dim inputRange As Range, r As Range, c As Range
Dim myDestWB As Workbook
Application.ScreenUpdating = False
'''' Open file dialog and choose folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = True Then
FolderName = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With

'''' Location of DataValidation cell
Set r = Worksheets("Dashboard").Range("c80")
'''' Get DataValidation values
Set inputRange = Evaluate(r.Validation.Formula1)

'''' Loop through DataValidation list
For Each c In inputRange
r.Value = c.Value
FName = c.Value
'
Sheets("Details").Columns("A:Q").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Dashboard!Supervisor"), CopyToRange:=Range("B82:k82"), _
Unique:=False
Range("B82:K82").Select
ActiveWorkbook.Worksheets("Dashboard").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Dashboard").Sort.SortFields.Add Key:=Range( _
"J83:J6215"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("Dashboard").Sort.SortFields.Add Key:=Range( _
"G83:G6215"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").Sort.SortFields.Add Key:=Range( _
"F83:F6215"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Dashboard").Sort.SortFields.Add Key:=Range( _
"B83:B6215"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Dashboard").Sort
.SetRange Range("B82:K6215")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Range("B83:K5000").Select
Selection.copy
Sheets("Template").Select
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.Select
ActiveCell.SpecialCells(xlLastCell).Select
Range("A1").Select
ActiveWindow.SmallScroll Down:=45
ActiveCell.Offset(82, 1).Range("A1").Select
ActiveWindow.SmallScroll Down:=3
Selection.End(xlToRight).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.copy
Sheets.Add After:=ActiveSheet
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Sheets("Template").Select
Range("A82").Select
ActiveSheet.Paste
Selection.End(xlDown).Select
ActiveWindow.SmallScroll Down:=3
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.copy
Application.CutCopyMode = False

Next c

End Sub

1580583019783.png
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
I was able to update my code a little and get the data to paste the first person selected perfectly into my template, but then the second person now is way down the sheet and off to the right like 9 columns. But the third person's results are directly under person two..

What do I need to update in the below code
VBA Code:
    Range("B83:K83").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.copy
    Sheets("Template").Select
    ActiveSheet.Paste
    ActiveCell.SpecialCells(xlLastCell).Select
    ActiveCell.Offset(0, -9).Range("A1").Select
    Sheets("Dashboard").Select
    Range("B83:k50000").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=-6
    Selection.Clear
 
Upvote 0

Forum statistics

Threads
1,223,889
Messages
6,175,223
Members
452,620
Latest member
dsubash

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