Loop through every auto filter drop down, copy result cell and paste to another sheet

[RINCONPAUL]

In the attachment, I want to Auto Filter each RTG column. So, for RTG1 the code would auto filter it, select the top most value, cell A1 will now change, copy that value to Sheet2 and paste into cell B2. Then repeat loop with 2nd value in RTG1 dropdown, copy A1, paste to B3. The code will complete all the options listed in the dropdown, then move to RTG2, copy and paste the resultant A1 values to C2 down, once finished move onto RTG3 and repeat until all available columns and drop down values have been pasted. Once a RTG dropdown criteria has been worked down, Select All to make all the cells available for the next column filter.

In a real world scenario there would be 30+ RTG? columns, all with different criteria. The code will head right until it reaches a blank column and stop. I could record a macro but it would be damn long, as the criteria and number of RTG cols make for a lot of repeats.

Thanks in anticipation.

[p45cal]

I could record a macro but it would be damn long, as the criteria and number of RTG cols make for a lot of repeats.
Agreed, and it's difficult to know how many and what's in each drop down so I thought a different approach might work.
In the attached, on the results sheet there are a couple of buttons, each calling up a different way of producing the results you have.
One uses advanced filter and some calculations, the other uses a temporary pivot table. They both seem to handle blanks properly, but test them.
The macros would have to be adapted to make sure they process the right sheet and areas but it should be a start.

[RINCONPAUL]

Brilliant stuff p45cal. I've searched long and hard to find a solution and 'BANG', you nailed it, not once but twice.

Thankyou so much. I'll put it to a test on other data ASAP

[RINCONPAUL]

Hi p45cal. I've been testing your code and have a question? Is there a limit to what this code can handle by way of cols/rows? Reason being that when I load a full size worksheet in comprising 15000 rows and 100 columns, no results appear at all. The only thing that happens is a new blank sheet is created between Sheet1 and Results. I'm working my way up with say 15000 rows and 3 cols and it's handling that OK.

If you have time, thanks

[p45cal]

It should be OK, can you send me a big file?
If data is sensitive either put it in the cloud with an access password which you can send me in a Private Message here, or send me a Private Message for an email address to send it to.

[RINCONPAUL]

You're a champion, but I had a thought, some of the columns of values contain blank cells! Would that be the reason? if not I'll forward you a bigger spreadsheet. Nup, no secrets in this stuff, unless you're a betting man? LOL

[p45cal]

Not sure. Let me take a peep at the file. See PM.

[p45cal]

There was a difference between the design of the sample sheet you supplied here and the bigger one you sent me. I had used Excel's placement of an Autofilter to determine the range to process (the table). Completely blank rows/columns within the table would have caused problems, but you don't have any. The problem was that you had a fully populated row 1 on the bigger sheet whereas only A1 was occupied on the smaller one. So a tweak to the code was made, which now uses current region and shifts the result down a row, leaving out the top row. Again, no completely blank rows or columns (if you have completely-populated row and column headers it should be fine). It's important that you don't have non-table data immediately next to the table; the table should be bounded by a completely blank row and column (or the edge of the sheet).

On testing, the two macros, among some 11,000 results, 3 were different. They were in RTG34 and RTG35, where you were looking for question marks and asterisks. These were being interpreted by Excel as wildcard characters in SUMIF. Excel's Help on Sumif says: "Important: Any text criteria or any criteria that includes logical or mathematical symbols must be enclosed in double quotation marks ("). If the criteria is numeric, double quotation marks are not required."
I've tweaked the code to handle * and ? but not any other 'logical or mathematical symbols'. Just something to be aware of. It may not matter, because the pivot table method didn't cause any problems, and is much faster, so I'd expect you would plump for that method.

I'll send the file direct to you since it's quite big.

The resultant code for anyone remotely interested:
Sub Macro1()
'uses advanced filter and sumif.
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Set OrigSht = Sheets("sheet1")
Set ResultsStartCell = Sheets("Results").Range("F2")
ResultsStartCell.CurrentRegion.Clear
With OrigSht
Set yyy = .Range("A1").CurrentRegion
Set yyy = yyy.Resize(yyy.Rows.Count - 1).Offset(1)
Set RngToSum = yyy.Columns(1)
For colm = 2 To yyy.Columns.Count
If UCase(Left(yyy.Columns(colm).Cells(1).Value, 3)) = "RTG" Then
Set newsht = Sheets.Add
yyy.Columns(colm).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=newsht.Range("A1"), Unique:=True
mySort newsht.UsedRange
If Application.WorksheetFunction.CountBlank(yyy.Columns(colm)) > 0 Then Z = 0 Else Z = 1
For Each cll In newsht.UsedRange.Offset(1).Resize(newsht.UsedRange.Rows.Count - Z)
If Len(cll.Value) = 0 Then myVal = "" Else myVal = cll.Value
myVal = Replace(Replace(myVal, "*", "~*"), "?", "~?") 'pd
cll.Value = Application.SumIf(yyy.Columns(colm), myVal, RngToSum)
Next cll
newsht.UsedRange.Copy ResultsStartCell.Offset(, ResultOffset)
ResultOffset = ResultOffset + 1
Application.DisplayAlerts = False: newsht.Delete: Application.DisplayAlerts = True
End If
Next colm
End With 'origsht
ErrHandler:
Application.ScreenUpdating = True
Sheets("Results").Activate
End Sub
Sub mySort(rng As Range)
With rng.Parent.Sort
.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub Macro10()
'uses temporary pivot tables.
Dim PreviousPF As PivotField, yyy As Range
On Error GoTo ErrHandler
Application.ScreenUpdating = False

Set OrigSht = Sheets("sheet1")
Set ResultsStartCell = Sheets("Results").Range("CJ2")
ResultsStartCell.CurrentRegion.ClearContents 'pd
With OrigSht
Set yyy = .Range("A1").CurrentRegion
Set yyy = yyy.Resize(yyy.Rows.Count - 1).Offset(1)
Set newsht = Sheets.Add
Set pt = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=yyy).CreatePivotTable(TableDestination:=newsht.Range("A1"))
End With
With pt
For Each pf In .PivotFields
pf.Subtotals(1) = True
pf.Subtotals(1) = False
Next pf
.ColumnGrand = False
.RowGrand = False
.AddDataField .PivotFields(1), , xlSum
For Each pf In .PivotFields
If UCase(Left(pf.Name, 3)) = "RTG" Then
If Not PreviousPF Is Nothing Then PreviousPF.Orientation = xlHidden
pf.Orientation = xlRowField
pf.Position = 1
Set PreviousPF = pf
ResultsStartCell.Offset(, ResultOffset) = pf.Name
.DataBodyRange.Copy ResultsStartCell.Offset(1, ResultOffset)
ResultOffset = ResultOffset + 1
End If
Next pf
Application.DisplayAlerts = False: newsht.Delete: Application.DisplayAlerts = True
End With 'pt
ErrHandler:
Application.ScreenUpdating = True
Sheets("Results").Activate
End Sub

[RINCONPAUL]

p45cal, mate, you are a VBAX Master by title, but in my mind, a VBAX MasterBlaster. Fantastic workmanship. Is there nothing you can't solve?? Give the bloke a pay rise, somebody!!

ThankYOU