Advanced excel problem- beyond my knowledge! Let me know if this is possible.

[ExcelHelp123456]

Hey Ya'll,

Just need some help with an excel issue i'm having that's a bit more advanced that I know how to do.. Is it possible to move these descriptions to the lines that correspond with above and to the left? Hopefully this makes more sense with the picture below. Thanks!

 

[L. Howard]

I have been pondering the screen shots for a bit.

I sorta get the idea about moving the "displaced header row" (B to H) to the top or the row of the 'item changes row' in column A. Which would include the lone string "Color" in the J column.

But if column J "Option 2 Value" is always the string "Color" maybe delete the entire column of "Color" and just append "Color" to column J along with what ever means one is able to use to move the "displaced header row" to its proper row.

Can one assume all the columns from K to last used column can be ignored?

Is it possible to provide a link to a accurate example worksheet with about the first 100 rows of your data, instead of a screen shot. You cannot attach a workbook, but a link is okay. I would give it a look see, but nothing jumps into my head at this point. Don't link the zillion rows and sheets workbook!

Howard

 

[L. Howard]

I tried Michael M's code on a very short data set and could not get it to work for me.

I dug out an archived code of mine and added a couple of sort lines to it.
Goes in a standard module and you would use it slightly different than the first Input Box prompt explains. It says you can enter five columns to FILTER separated by a / , backslash.

Run the code.
For use on your data, since we will only filter on column A, only enter a single "a" or "A" then OK. The second Input Box pops up asking for the criteria to sort by.
Start out with entering "admiral" (no quotes) then OK.

Check the results to see if the displaced B to H rows are now at the top of the "admiral" list along with the "color" in column J.

Next run the code for column "A" again and enter "admiral-1" in the second box > OK. Recheck results. Does it work for you on your sheet?

Problem is its just a little bit faster than copy - paste. It is blink fast dealing with 30 to 50 rows for each filter and sort. But it is a number of keystrokes and some data entry to employ for each unique item in column A.

It might be possible to make a list of all the unique items in column A, or at least say a manageable number for entering into an array and do the filtering by looping through the array. The sorting would be automatic with each filtering from each element of the array.

I'm a bit weak on arrays, but will muddle about with a try.

A link to an example worksheet would still be helpful, my test sheet may not match exactly, although the sheet is not too complex I think.

Howard

Option Explicit
Sub Filter_On_Column_Values_LHK()
Dim FilterField
Dim OneRng As Range
Dim colArr As String
Dim crtArr As String
Dim myArrCol As Variant
Dim myArrCrt As Variant
Dim i As Long, ii As Long, LRow As Long

Set OneRng = Range("A1:J" & Cells(Rows.Count, "A").End(xlUp).Row)

    'You can use small letters or capitals
    colArr = InputBox("Enter the Column's character." & vbCr & _
                    "Up to five Columns." & vbCr & vbCr & _
                    "With a back slash /  between, no spaces ")
    If Len(colArr) = 0 Then
        MsgBox "No Column Entry"
        Exit Sub
    End If
    
    If InStr(colArr, "/") > 0 Then
        myArrCol = Split(colArr, "/")
    Else
        ReDim myArrCol(0)
        myArrCol(0) = colArr
    End If
  
  
    With Sheets("Sheet1")
 
        For i = LBound(myArrCol) To UBound(myArrCol)
            'The criteria will be entered for each column separately. You can enter
            'multiple criterias for each column
        
            crtArr = InputBox("Enter a Criteria for COLUMN " & UCase(myArrCol(i)) & vbCr & _
                    "Up to five Criteria." & vbCr & vbCr & _
                    "With a back slash /  between, no spaces ")
            If Len(crtArr) = 0 Then
                MsgBox "No Criteria Entry"
                Exit Sub
            End If
            If InStr(crtArr, "/") > 0 Then
                myArrCrt = Split(crtArr, "/")
            Else
                ReDim myArrCrt(0)
                myArrCrt(0) = crtArr
            End If
        
            For ii = LBound(myArrCrt) To UBound(myArrCrt)
         
                If UBound(myArrCrt) = 0 Then
            
                    OneRng.AutoFilter Field:=Asc(UCase(myArrCol(i))) - 64, Criteria1:=myArrCrt(0)
                Else
                
                    OneRng.AutoFilter Field:=Asc(UCase(myArrCol(i))) - 64, Criteria1:=myArrCrt, Operator:=xlFilterValues
                End If
            Next ii
            
            Range("B:H").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes
            Range("J:J").Sort Key1:=Range("J2"), Order1:=xlAscending, Header:=xlYes
            Selection.AutoFilter

        Next 'i
 
 End With
End Sub

 

[L. Howard]

Try this, a virtual re-write of my Post#12 macro. Thanks to Claus @ MS PUBLIC

I constructed a mock worksheet which I believe duplicates the screenshots you posted. (Minus the columns of data beyond column J)
Column A has 15,000 rows with strings in 10 row duplicates, and therefore 1500 "displaced rows" from columns B to H and a string "color" in column J.

There is timing code if you want to the run time on your data, un-comment those code lines for a msgbox readout.
Run time for the 15,000 / 1500 data set on my lap top is less than 3 seconds.

Hope it works for your data/sheet.

Howard

Option Explicit

Sub Filter_On_Column_Values()

Dim FilterField
Dim OneRng As Range, c As Range
Dim myCol As String
Dim myArrCrt As Variant, varTmp As Variant
Dim myDic As Object
Dim i As Long, ii As Long, LRow As Long
Dim myCount As Long, Start As Long

''/a timer if you want
      'Dim StartTime As Double
      'StartTime = Timer
''/

Application.ScreenUpdating = False

With Sheets("Sheet1")
   LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   myCol = "A"

   .Range("J2:J" & LRow).ClearContents
   
   varTmp = .Range("A2:A" & LRow)

   Set myDic = CreateObject("Scripting.Dictionary")

   For i = LBound(varTmp) To UBound(varTmp)
      myDic(varTmp(i, 1)) = varTmp(i, 1)
   Next

   myArrCrt = myDic.items
   
   For i = LBound(myArrCrt) To UBound(myArrCrt)

      Set OneRng = .Range(.Cells(1, myCol), .Cells(LRow, myCol))
      Start = Application.Match(myArrCrt(i), OneRng, 0)
      myCount = Application.CountIf(OneRng, myArrCrt(i))
      Set OneRng = .Range(.Cells(Start, "B"), .Cells(Start + myCount - 1, "H"))
      OneRng.Sort Key1:=.Range("B" & Start), Order1:=xlAscending, Header:=xlNo
      .Range("J" & Start) = "Color"

   Next 'i
 
End With

 Application.ScreenUpdating = True
 
''/Output the number of seconds it took to run in 2 decimal places.
      'MsgBox "Total time: " & Round(Timer - StartTime, 3) & " seconds"
''/

End Sub

 

[FDibbins]

Im wondering if a COUNTIFS() based on A:A=A1 and J:J <>"", the sorted based on A and then on that might work?