continued from last post.......
Private Sub Worksheet_Change(ByVal Target As Range)
This reacts to changes of values in column A, for example when selecting a value from the drop down list
Initially a "Blank" selection is changed to "" , and if a "-" was given then the original range is restored
The rest of this routine is very similar to the routine here https://www.eileenslounge.com/viewto...245286#p245218 The difference is that we need here now to determine one set of column indices to use in a code line like pseudo the following to get the required filtered range
Output() = Index ( Cells , allRowIndicies , someColumnIndicies)
( The previous example at that link required all columns and 2 sets of some rows for two outputs based on a column having a Y or not )
Code:Sub testieCLDoWhile() Dim testieletter As String Let testieletter = CLDoWhile(3) ' should return "C" End Sub ' CLDoWhile is a Function to get column letter from column number Function CLDoWhile(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html Dim rest As Long 'Variable for what is "left over" after subtracting as many full 26's as possible Do ' Let rest = ((lclm - 1) Mod 26) 'Gives 0 to 25 for Column Number "Left over" 1 to 26. Better than ( lclm Mod 26 ) which gives 1 to 25 for clm 1 to 25 then 0 for 26 ' Let FukOutChrWithDoWhile = Chr(65 + rest) & FukOutChrWithDoWhile 'Convert rest to Chr Number, initially with full number so the "units" (0-25), then number of 26's left over (if the number was so big to give any amount of 26's in it, then number of 26's in the 26's left over (if the number was so big to give any amount of 26 x 26's in it, Enit ? ' 'OR Let CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest. 'lclm = (lclm - (rest + 1)) \ 26 ' As the number is effectively truncated here, any number from 1 to (rest +1) will do in the formula Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it End Function ' ' Sub testieWksChange() Call Worksheet_Change(Me.Range("A2")) Let Application.EnableEvents = True ' Just incase it got turned off End Sub Private Sub Worksheet_Change(ByVal Target As Range) If IsArray(Target.Value) Then Exit Sub Rem 1 main worksheet data range info Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub ' only do anything for a selection in the A column range. Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column If Target.Value = "Blank" Then Let Application.EnableEvents = False: Let Target.Value = "": Let Application.EnableEvents = True Rem 2 test data range reset If Target.Value = "-" Then Let Application.EnableEvents = False Let Me.Range("C1", Me.Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value = Worksheets("Sheet1 (2)").Range("C1", Worksheets("Sheet1 (2)").Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value Let Application.EnableEvents = True Rem 3 Get indices( column numbers) for required columns, and all row indicies '3a) indices( column numbers) for required columns Else ' selected value is a unique value or "" for "Blank" Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value ' I dont need the first and third column, but it makes it easier to keep track of the correct columns indicie Dim Cnt As Long Dim strClms As String: Let strClms = "1 2 " ' For our required columns containing in this row the target selected value For Cnt = 3 To CntClms ' check columns from 3 for a match to the value in column 1 If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then ' This is indication of wanted column as it contains the value Let strClms = strClms & Cnt & " " Else End If Next Cnt Let strClms = Left(strClms, Len(strClms) - 1) ' Take off last " " Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare) Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1) ' for {1,2,7,9} = required columns For Cnt = 0 To UBound(clmsSpt()) Let Clms(Cnt + 1) = clmsSpt(Cnt) Next Cnt '3b) all data ro indicies Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")") ' = {1;2;3;4;5;6;7;8;9;.......... , CntItms} = required rows ( all rows are required ) Rem 4 Output filtered columns Dim arrOut() As Variant: Let arrOut() = Application.Index(Cells, Rws(), Clms()) Let Application.EnableEvents = False Me.Cells.ClearContents Let Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut() Let Application.EnableEvents = True End If End Sub Sub testsort() Dim df As String, d As String df = "df" Dim var If IsNumeric(df) Then var = CLng(df) Dim dg As String dg = "dg" MsgBox (dg > df) & " " & (dg > d) End Sub




Reply With Quote
Bookmarks