Page 13 of 61 FirstFirst ... 3111213141523 ... LastLast
Results 121 to 130 of 604

Thread: Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

  1. #121
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10

    Test Sort Routine

    SFNSAFSAFS

    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg.A0opm95t2XEA0q3Kshmu uY
    https://www.youtube.com/watch?v=bRd4mJglWiM&lc=UgxRmh2gFhpmHNnPemR4AaABAg
    https://eileenslounge.com/viewtopic.php?p=318868#p318868
    https://eileenslounge.com/viewtopic.php?p=318311#p318311
    https://eileenslounge.com/viewtopic.php?p=318302#p318302
    https://eileenslounge.com/viewtopic.php?p=317704#p317704
    https://eileenslounge.com/viewtopic.php?p=317704#p317704
    https://eileenslounge.com/viewtopic.php?p=317857#p317857
    https://eileenslounge.com/viewtopic.php?p=317541#p317541
    https://eileenslounge.com/viewtopic.php?p=317520#p317520
    https://eileenslounge.com/viewtopic.php?p=317510#p317510
    https://eileenslounge.com/viewtopic.php?p=317547#p317547
    https://eileenslounge.com/viewtopic.php?p=317573#p317573
    https://eileenslounge.com/viewtopic.php?p=317574#p317574
    https://eileenslounge.com/viewtopic.php?p=317582#p317582
    https://eileenslounge.com/viewtopic.php?p=317583#p317583
    https://eileenslounge.com/viewtopic.php?p=317605#p317605
    https://eileenslounge.com/viewtopic.php?p=316935#p316935
    https://eileenslounge.com/viewtopic.php?p=317030#p317030
    https://eileenslounge.com/viewtopic.php?p=317030#p317030
    https://eileenslounge.com/viewtopic.php?p=317014#p317014
    https://eileenslounge.com/viewtopic.php?p=316940#p316940
    https://eileenslounge.com/viewtopic.php?p=316927#p316927
    https://eileenslounge.com/viewtopic.php?p=316875#p316875
    https://eileenslounge.com/viewtopic.php?p=316704#p316704
    https://eileenslounge.com/viewtopic.php?p=316412#p316412
    https://eileenslounge.com/viewtopic.php?p=316412#p316412
    https://eileenslounge.com/viewtopic.php?p=316254#p316254
    https://eileenslounge.com/viewtopic.php?p=316046#p316046
    https://eileenslounge.com/viewtopic.php?p=317050&sid=d7e077e50e904a138c794e1f2115da95#p317050
    https://www.youtube.com/@alanelston2330
    https://www.youtube.com/watch?v=yXaYszT11CA&lc=UgxEjo0Di9-9cnl8UnZ4AaABAg.9XYLEH1OwDIA35HNIei0z-
    https://eileenslounge.com/viewtopic.php?p=316154#p316154
    https://www.youtube.com/watch?v=TW3l7PkSPD4&lc=UgwAL_Jrv7yg7WWC8x14AaABAg
    https://teylyn.com/2017/03/21/dollarsigns/#comment-191
    https://eileenslounge.com/viewtopic.php?p=317050#p317050
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 07-28-2024 at 02:20 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  2. #122
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10
    Routines called by test code , Sub TestsStringArray() , in last post:

    Code:
    Sub subSort2DArrayMultiElements( _
                sparray() As String, _
                spOrder As String _
                )
    ' Sort an array with TWO dimensions.
    ' Assume Sort on the 2nd Dimension
    '  so assumes it IS a 2 Dim array.
    ' Sort on more than one element.
    '
    ' This uses a merge sort.
    ' The sort is set up as ascending and not case sensitive.
    '
    ' Use
    '    subSortMultiElements Array, Order
    '
    ' Ex Order = "1 4 0 3 2".
    ' Not all elements need be specified.
    ' Any delimiter may be used.
    '
    
    Dim lnglArrayIndex As Long
    Dim lnglElements As Long
    Dim lnglEndArray As Long
    Dim lnglKey As Long
    Dim lnglLbound As Long
    Dim lnglM As Long
    Dim lnglN As Long
    Dim lnglNumSortKeys As Long
    Dim lnglO As Long
    Dim lnglP As Long
    Dim lnglPrevKeyCol As Long
    Dim lnglThisKeyCol As Long
    Dim lnglUBound As Long
    Dim lngSubArrayRows As Long
    Dim slKeyVal As String
    Dim slOrder As String
    Dim slOrderArray() As String
    Dim slSubArray() As String
    Dim slTopKeyVal As String
    
    lnglElements = UBound(sparray, 2)
    
    ' Make an Order Array.
    slOrder = spOrder
    
    ' Delimiter?
    ' Disappear the numbers.
    For lnglN = 0 To 9
      slOrder = Replace(slOrder, CStr(lnglN), "")
    Next lnglN
    slOrder = Trim$(slOrder)
    
    ' Should only have the delimiter left.
    If Len(slOrder) = 0 Then
      slOrderArray = Split(spOrder, " ")
    Else
      slOrderArray = Split(spOrder, Mid$(slOrder, 1, 1))
    End If
    
    lnglNumSortKeys = UBound(slOrderArray) + 1
    
    ' Always Sort on the FIRST Key.
    lnglKey = CLng(slOrderArray(0))
    subArrayMergeSort sparray, lnglKey
    
    ' Only one key?
    If lnglNumSortKeys = 1 Then
    
      Exit Sub
    
    End If
    
    ' Now go through the rest of the keys.
    ' We extract a series of arrays based on the KEY - 1.
    ' Any records to sort?
    If UBound(slOrderArray) > 0 Then
      For lnglN = 1 To lnglNumSortKeys - 1
          
        ' Pick up the start Value from Key-1.
        lnglPrevKeyCol = slOrderArray(lnglN - 1)
        lnglThisKeyCol = slOrderArray(lnglN)
        
        slTopKeyVal = sparray(0, lnglPrevKeyCol)
        
        lnglLbound = 0
        lnglUBound = UBound(sparray, 1)
        
        ' All the same.
        If sparray(lnglUBound, 0) = slTopKeyVal Then
          Exit For
        End If
        
        lnglArrayIndex = 0
        lnglEndArray = UBound(sparray)
        Do
          lnglLbound = lnglArrayIndex
          slTopKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol)
          Do
            If lnglArrayIndex > lnglEndArray Then
              Exit Do
            End If
          
            slKeyVal = sparray(lnglArrayIndex, lnglPrevKeyCol)
            
            If slKeyVal <> slTopKeyVal Then
              
              lnglUBound = lnglArrayIndex - 1
              Exit Do
              
            End If
          
            lnglArrayIndex = lnglArrayIndex + 1
          
          Loop
          
          ' No need to sort if there's only ONE row.
          lngSubArrayRows = lnglUBound - lnglLbound
          If lngSubArrayRows > 1 Then
          
    
            ' Get those rows.
            ReDim slSubArray(lnglUBound - lnglLbound, lnglElements)
            lnglP = 0
            For lnglM = lnglLbound To lnglUBound
              For lnglO = 0 To lnglElements
                slSubArray(lnglP, lnglO) = sparray(lnglM, lnglO)
              Next lnglO
              lnglP = lnglP + 1
            Next lnglM
            
            ' Sort 'em.
            subArrayMergeSort slSubArray, lnglThisKeyCol
            
            ' Put 'em back.
            lnglP = 0
            For lnglM = lnglLbound To lnglUBound
              For lnglO = 0 To lnglElements
                sparray(lnglM, lnglO) = slSubArray(lnglP, lnglO)
              Next lnglO
              lnglP = lnglP + 1
            Next lnglM
            
          End If
          
          If lnglArrayIndex > lnglEndArray Then
            Exit Do
          End If
        
        Loop
        
      Next lnglN
    End If
    
    ' ***********************************************************************
    End Sub
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  3. #123
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10
    KVKDLDKLJ
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  4. #124
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10
    Code:
    Sub subArrayMergeSort( _
                ByRef vpArray As Variant, _
                ByVal lngpElement As Long, _
                Optional vpMirror As Variant, _
                Optional ByVal lngpLeft As Long, _
                Optional ByVal lngpRight As Long _
                )
    ' http://www.vbforums.com/showthread.php?t=473677
    '
    ' Recurse Merge Sort a TWO Dim array.
    '
    ' Use...
    '  subMergeSort Array, Element
    '
    ' lngpLeft and lngpRight are 0 at the start.
    '
    ' Sorts on ONE element.
    '
    
    Dim blnlRightIsLessThanLeft As Boolean
    Dim blnlLeftIsGreaterThanRight As Boolean
    Dim blnlIsNumeric As Boolean
    Dim lnglLeftStart As Long
    Dim lnglMid As Long
    Dim lnglOutputStart As Long
    Dim lnglRightStart As Long
    Dim vlSwap As Variant
    Dim lnglCElement As Long
    Dim lnglNumElements As Long
    Dim vlSwapRow() As Variant
    
    ' This is just to gain a tiiiny bit of speed.
    If IsNumeric(vpArray(0, lngpElement)) = True Then
      blnlIsNumeric = True
    Else
      blnlIsNumeric = False
    End If
    
    lnglNumElements = UBound(vpArray, 2)
    ReDim vlSwapRow(lnglNumElements)
    If lngpRight = 0 Then
      lngpLeft = LBound(vpArray, 1)
      lngpRight = UBound(vpArray, 1)
      ReDim vpMirror(lngpLeft To lngpRight, 0 To lnglNumElements)
    End If
    lnglMid = lngpRight - lngpLeft
    
    Select Case lnglMid
    Case 0
    
    Case 1
      
      ' Changed this to make it case insensitive.
      ' If vpArray(lngpLeft) > vpArray(lngpRight) Then
      If blnlIsNumeric = True Then
        If CLng(vpArray(lngpLeft, lngpElement)) _
          > CLng(vpArray(lngpRight, lngpElement)) _
        Then
            blnlLeftIsGreaterThanRight = True
        Else
            blnlLeftIsGreaterThanRight = False
        End If
      Else
        If StrComp( _
            vpArray(lngpLeft, lngpElement), _
            vpArray(lngpRight, lngpElement), _
            vbTextCompare) _
            = 1 _
        Then
          blnlLeftIsGreaterThanRight = True
        Else
          blnlLeftIsGreaterThanRight = False
        End If
      End If
      
      If blnlLeftIsGreaterThanRight Then
        
        ' SWAP the whole row.
        For lnglCElement = 0 To lnglNumElements
          vlSwapRow(lnglCElement) = vpArray(lngpLeft, lnglCElement)
        Next lnglCElement
        
        For lnglCElement = 0 To lnglNumElements
          vpArray(lngpLeft, lnglCElement) = vpArray(lngpRight, lnglCElement)
        Next lnglCElement
        
        For lnglCElement = 0 To lnglNumElements
          vpArray(lngpRight, lnglCElement) = vlSwapRow(lnglCElement)
        Next lnglCElement
        
    '    vlSwap = vpArray(lngpLeft)
    '    vpArray(lngpLeft) = vpArray(lngpRight)
    '    vpArray(lngpRight) = vlSwap
      
      End If
    
    Case Else
      
      lnglMid = lnglMid \ 2 + lngpLeft
      subArrayMergeSort vpArray, lngpElement, vpMirror, lngpLeft, lnglMid
      subArrayMergeSort vpArray, lngpElement, vpMirror, lnglMid + 1, lngpRight
    
      ' Merge the resulting halves
      
      lnglLeftStart = lngpLeft ' start of first (left) half
      lnglRightStart = lnglMid + 1  ' start of second (right) half
      lnglOutputStart = lngpLeft  ' start of output (mirror array)
      
      Do
        
        ' Changed this to make it case insensitive.
        ' If vpArray(lnglRightStart) < vpArray(lnglLeftStart) Then
        
        If blnlIsNumeric = True Then
        
          If CLng(vpArray(lnglRightStart, lngpElement)) _
              < CLng(vpArray(lnglLeftStart, lngpElement)) _
          Then
            blnlRightIsLessThanLeft = True
          Else
            blnlRightIsLessThanLeft = False
          End If
        Else
          If StrComp( _
              vpArray(lnglRightStart, lngpElement), _
              vpArray(lnglLeftStart, lngpElement), _
              vbTextCompare) = _
              -1 _
          Then
            blnlRightIsLessThanLeft = True
          Else
            blnlRightIsLessThanLeft = False
          End If
        End If
        
        If blnlRightIsLessThanLeft Then
        
          ' COPY the complete row.
    '      vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
          For lnglCElement = 0 To lnglNumElements
            vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
          Next lnglCElement
          
          
          lnglRightStart = lnglRightStart + 1
          If lnglRightStart > lngpRight Then
            For lnglLeftStart = lnglLeftStart To lnglMid
              lnglOutputStart = lnglOutputStart + 1
              
              ' COPY the whole row.
    '          vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
              For lnglCElement = 0 To lnglNumElements
                vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
              Next lnglCElement
                     
            Next
            Exit Do
          End If
        Else
        
          ' COPY the complete row.
    '      vpMirror(lnglOutputStart) = vpArray(lnglLeftStart)
          For lnglCElement = 0 To lnglNumElements
            vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglLeftStart, lnglCElement)
          Next lnglCElement
          
          
          lnglLeftStart = lnglLeftStart + 1
          If lnglLeftStart > lnglMid Then
            For lnglRightStart = lnglRightStart To lngpRight
              lnglOutputStart = lnglOutputStart + 1
              
              ' COPY the complete row.
    '          vpMirror(lnglOutputStart) = vpArray(lnglRightStart)
              For lnglCElement = 0 To lnglNumElements
                vpMirror(lnglOutputStart, lnglCElement) = vpArray(lnglRightStart, lnglCElement)
              Next lnglCElement
              
            Next
            
            Exit Do
          End If
        End If
        
        lnglOutputStart = lnglOutputStart + 1
      
      Loop
      For lnglOutputStart = lngpLeft To lngpRight
        
        ' Swap the complete row.
    '    vpArray(lnglOutputStart) = vpMirror(lnglOutputStart)
        For lnglCElement = 0 To lnglNumElements
          vpArray(lnglOutputStart, lnglCElement) = vpMirror(lnglOutputStart, lnglCElement)
        Next lnglCElement
        
      Next
    End Select
    
    ' *********************************************************************
    End Sub
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  5. #125
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10

    VBA Filter for Columns instead of Rows. Phillip Filters

    Coding for answer to this Thread
    https://www.eileenslounge.com/viewto...p?f=30&t=31740

    There are two main routines. They both are event routines reacting when the range A2 : A_ last data row is used.
    A selection change routine will make the drop down list the first time that a cell is selected.
    A value change routine, ( in the next post ) , makes a filtered range containing just columns having the selected value in that selected row

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    This makes a drop down list in column A when a cell is selected ( The range of ordered values needed to fill the drop down lists is made by this routine and it is placed in a worksheet with Name "DataSaladinValagationLists" )
    This is briefly how this routine works:
    It only does anything for a selection in the A column range.
    It only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row
    The range of data for that row is copied to the clipboard, excluding empty cells . The text held in the clipboard is retrieved.
    A row in Excel is held in the clipboard as a string with a vbTab as separator, and this string also has a trailing vbCr & vbLf which we remove. http://www.eileenslounge.com/viewtop...=31395#p242941
    A 1 Dimensional array is made from the retrieved string, strSptInDrpPlop() , and this is used to produce a simple string which only has unique cell values in it. This string is then used to replace the strSptInDrpPlop() contents with unique values
    The unique values as well as a leading “-“ and trailing “Blank” are pasted out to the worksheet "DataSaladinValagationLists"


    Code:
    Sub test()
     Let Application.EnableEvents = True
     Call Worksheet_SelectionChange(Me.Range("A3"))
     Let Application.EnableEvents = True
    End Sub
    ' =DataSaladinValagationLists!A2:A3
    
    
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' for initial making of list for drop down
        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.
        If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub ' We already have made a drop down list - only does anything if there is not already a range of ordered values needed to fill the drop down list for the selected row
    Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
    Rem 2 make drop down list for this row
    ' 2a) get unique list of all values in row
     Let Application.EnableEvents = False
     Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy ' The range of data for that row is copied to the clipboard, excluding empty cells
     Let Application.EnableEvents = True
    Dim Dtaobj As Object '  Late Binding equivalent'   If you declare a variable as Object, you are late binding it.  http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
     Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/       http://www.eileenslounge.com/viewtopic.php?f=30&t=31547#p244124
     Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText()
     Let strClip = Left(strClip, Len(strClip) - 2) ' Take off last vbCr & vbLf
    Application.CutCopyMode = False ' Clear clipboard, stop screen flicker
    Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare) ' a row in Excel is held as a string with a vbTab as seperator. The array made here may contain duplicated cell values
    Dim UnEeks As String: Let UnEeks = " " ' this string will have unique cell values only. I need an initial " " to make sure i can check for a number like " 7 " not just "7" as that might get confused with "27"
    Dim Cnt As Long
        For Cnt = 0 To UBound(strSptInDrpPlop())
         If InStr(1, UnEeks, " " & Trim(strSptInDrpPlop(Cnt)) & " ", vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then  ' I am not sure yet if the last check is needed.
          Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " " ' A similar string to the original retrieved from the clipboard  strClip  is made with the difference that the seperator is a space and we have no duplicated cell values
         Else
         End If
        Next Cnt
    'Let UnEeks = Replace(UnEeks, vbTab, "", 1, -1, vbBinaryCompare) 'remove rogue vbtabs
     Let UnEeks = Mid(UnEeks, 2, Len(UnEeks) - 2) ' take off first and last " "                                             ' Left(UnEeks, Len(UnEeks) - 3) ' take off " " & vbCr & vbLf
     'Let UnEeks = "-" & " " & UnEeks & "Blanks"
     Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare) ' Replace the 1 Dimensional array  values with only unique values
    ' 2b) sort list ( Bubble sort )
    Dim Eye As Long, Jay As Long
        For Eye = 0 To UBound(strSptInDrpPlop()) - 1 'I want to take the next in the array, starting at the first. The process below should result in the smallest being put at this position, because I go through the rest , the inner Jay loop, and when ever i find something smaller i swap so the smalles comes here
           For Jay = Eye + 1 To UBound(strSptInDrpPlop()) ' I now go through comparing with each of the rest, the Jays
               If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then ' This is to overcome an extra problem that I have: I have strings, and VBA thinks that "6" is bigger than "35" but it thinks  6  is  less than   35
                    If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) Then ' This means that I am bigger than the next. So I will swap . I keep doing this which will have the effect of putting the smallest in the current Eye. By the next Eye, I miss out the last, and any previous, which means I effectively do the same which puts the next smallest in this next Eye
                    Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
                    Else
                    End If
               Else ' if we have text, then VBA still allows a comparison to sort - like B > A returns True
                    If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then
                     Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp ' The element being compared with all the rest is bigger, so we swap it. The effect of this is that the smallest in the rest of the list being looked at, ( The Jay loop ) , will finally end up in the current Eye position.
                    Else
                    End If
               End If
           Next Jay
        Next Eye
    ' 2c) paste in values in DataSaladinValagationLists worksheet
        With Worksheets("DataSaladinValagationLists")
         Let .Range("A" & Target.Row & "").Value = "-" '                                                   ' a leading "-" ,
         Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop() '    unique values
         Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank" '                      '       and trailing "Blank"
        End With
    ' 2d) Make dropdown list
    Target.Validation.Delete ' This is only necerssary if a drop down is already there
    Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & ""
    End Sub
    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
    '
    '

    Code:
    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)
     MsgBox "7" < "77"
    Dim seven As String, seventyseven As String
     Let seven = "7": Let seventyseven = "77"
     MsgBox seven < seventyseven
     If seven < seventyseven Then MsgBox "True"
    Dim arrStr(0 To 1) As String
     Let arrStr(0) = "7": Let arrStr(1) = "77"
     MsgBox arrStr(0) < arrStr(1)
     MsgBox "6" < "34" ' FALSE !!!!!!!!!!******************
    End Sub
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  6. #126
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10

    Filter for columns not for rows. Phill Turd Sorted

    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
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  7. #127
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10

    Simplified coding

    Simplified coding for yasser
    https://eileenslounge.com/viewtopic....245769#p245769

    Coding for worksheet code module for worksheet "Sheet1"
    Code:
    Option Explicit
    Public Sub Worksheet_SelectionChange(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
        If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub
    Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
    Rem 2 make drop down list for this row
    
     Let Application.EnableEvents = False
     Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy
     Let Application.EnableEvents = True
    Dim Dtaobj As Object
     Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
     Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText()
     Let strClip = Left(strClip, Len(strClip) - 2)
    Application.CutCopyMode = False
    Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare)
    Dim UnEeks As String
    Dim Cnt As Long
        For Cnt = 0 To UBound(strSptInDrpPlop())
         If InStr(1, UnEeks, Trim(strSptInDrpPlop(Cnt)), vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then
          Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " "
         Else
         End If
        Next Cnt
    
     Let UnEeks = Left(UnEeks, Len(UnEeks) - 1)
     
     Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare)
    
    Dim Eye As Long, Jay As Long
        For Eye = 0 To UBound(strSptInDrpPlop()) - 1
           For Jay = Eye + 1 To UBound(strSptInDrpPlop())
               If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then
                    If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) Then
                    Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
                    Else
                    End If
               Else
                    If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then
                     Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
                    Else
                    End If
               End If
           Next Jay
        Next Eye
    
        With Worksheets("DataSaladinValagationLists")
         Let .Range("A" & Target.Row & "").Value = "-"
         Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop()
         Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank"
        End With
    
    Target.Validation.Delete
    Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & ""
    End Sub
    Function CLDoWhile(ByVal lclm As Long) As String
    Dim rest As Long
        Do
          
        Let CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile
        Let lclm = (lclm - (1)) \ 26
        
        Loop While lclm > 0
    End Function
    Public 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
    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
        
        Else
        Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value
        Dim Cnt As Long
        Dim strClms As String: Let strClms = "1 2 "
            For Cnt = 3 To CntClms
                If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then
                 Let strClms = strClms & Cnt & " "
                Else
                End If
            Next Cnt
         Let strClms = Left(strClms, Len(strClms) - 1)
        Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare)
        Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1)
            For Cnt = 0 To UBound(clmsSpt())
             Let Clms(Cnt + 1) = clmsSpt(Cnt)
            Next Cnt
        
        Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")")
    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


    Extra coding to go in normal code module
    Code:
    Option Explicit
    Sub Phillip_Filters()
    Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
     Dim Lr As Long: Let Lr = Ws1.Range("B" & Rows.Count & "").End(xlUp).Row
    Dim Cnt As Long
     Let Application.EnableEvents = False
        For Cnt = 2 To Lr
         Call Sheet1.Worksheet_SelectionChange(Ws1.Range("A" & Cnt & ""))
        Next Cnt
     Let Application.EnableEvents = True
    End Sub
    
    Sub ClearFilers()
    Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
     Dim Lr As Long: Let Lr = Ws1.Range("B" & Rows.Count & "").End(xlUp).Row
     Let Application.EnableEvents = False
     Ws1.Range("A2:A" & Lr & "").Validation.Delete
     Ws1.Range("A2:A" & Lr & "").ClearContents
     Let Application.EnableEvents = True
     Worksheets("DataSaladinValagationLists").Cells.ClearContents
    End Sub
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  8. #128
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10

    Sir Narios ... Positioning of procedure separation in the Visual Basic Development Environment

    Positioning of procedure separation Line in the Visual Basic Development Environment

    These are some notes based on a discussion here.. http://www.eileenslounge.com/viewtopic.php?f=30&t=31756
    Lisa Green had noticed something strange in how VBA divides procedures.....

    It appears that in VBA, that is to say in the Visual Basic Development Environment Window , ( that window seen by hitting Alt+F11 from a spreadsheet ) , the convention has been set to separate procedures by a line extending across the code pane Window.
    We see these as appearing as a series of underscores, __________________ , extending across the Visual Basic Development Environment Window
    Code:
    End Sub  '  The dividing line appears to us as a line of underscores ____ 
    


    Usually, if we did write exactly this ' The dividing line appears to us as a line of underscores ____ ' , on that terminating line above , then we would not see those underscores, ____ , as they get hidden in the terminating line:
    Hidden_____InDividingLine.JPG : https://imgur.com/7DyP9Om
    Attachment 2142
    The above screenshot shows the simplest case of routines with no “space” in between. In that simple case, the position of the dividing line is as expected in between the procedures. The situation is a bit more complicated if there is a separation in between procedures….

    Effect of blank lines ( or ‘commented lines ) In Between
    Between procedures we may add blank lines or ' comment lines. If this is done, it appears that the convention has been set to place the line somewhere between the procedures in this blank/ ‘comment range, and the lines above the line “belong” to the procedure above, that is to say the last or preeceding procedure, and the lines below the line “belong” to the procedure below, that is to say the next procedure, http://www.eileenslounge.com/viewtop...=31756#p245845

    The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
    There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________

    Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _

    Line continuation / Break points : single underscores _
    We note in passing , that single underscores are used in coding generally to allow us to divide a single line of code into several lines for ease of reading. For example:
    Code:
    ' http://www.excelfox.com/forum/showthread.php/2293-Move-values-in-rows-at-the-end-of-the-preceding-row-*SOLVED*?p=10891#post10891
    Sub LineContunuationUnderscores() ' https://docs.microsoft.com/en-us/dotnet/visual-basic/programming-guide/program-structure/how-to-break-and-combine-statements-in-code
      Dim LastRow As Long
      LastRow = Cells(Rows.Count, "A").End(xlUp).Row
      
    ' Without line breaks
      Range("A1:A" & LastRow) = Evaluate(Replace(Replace("IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)=""2018"",TRIM(A1:A@&"" ""&A2:A#),""""),IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", LastRow + 1), "@", LastRow))
      
    ' With Line breaks
      LastRow = _
         Cells(Rows.Count, "A").End(xlUp).Row
      Range("A1:A" & LastRow) = Evaluate(Replace(Replace(  _
                                "IF(ISNUMBER(0+SUBSTITUTE(SUBSTITUTE(" &  _
                                "A2:A#,"" "",""""),"","","""")),IF(LEFT(A1:A@,4)" & _
                                "=""2018"",TRIM(A1:A@&"" ""&A2:A#),"""")," &  _
                                "IF(LEFT(A1:A@,4)=""2018"",A1:A@,""""))", "#", _
                                LastRow + 1), "@", LastRow))
    '  This is _
         acceptable in _
    or out of a  procedure
    End Sub
    '  This is _
         acceptable in _
    or out of a  procedure__________________________________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    Further, we note that the line continuation , sometimes called a line break, _ , also applies to comments whether in a procedure or between procedures:
    ' This is _
    acceptable in _
    or out of a procedure


    _._________

    Determining position of horizontal line dividing procedures when blank or comment lines are between procedures
    Sir Narios
    .

    The documentation is not 100% clear on how the position of the dividing is determined , that is to say how the row on which it physically appears as a long series of underscores, __________________ is determined
    There is no obvious logic to the way in which the dividing line can be positioned, that is to say , how to determine on which the dividing line appears as a long series of underscores, __________________
    Some initial experiments suggest that is influenced by positioning of blank lines and any single underscores _
    There appear to be 3 scenarios to consider in order to place the line somewhere in between, ( 4 if you consider the simple case of all lines containing comments or all lines being blank )

    Scenario 0
    ' _(0)
    If all lines are blank, or all lines are full with comments ( which exclude line continuations )
    No single underscores in any line
    The break is immediately after the Last/ upper procedure. (This is the same as the case for no separation between routines )
    Scenario 0 .JPG : https://imgur.com/pA4grFL
    Attachment 2143
    Code:
    Sub Scenario_0()
    ' _(0)
    End Sub___________________________________________________________________________________________________________________________________________________________________________________________________________
    
    
     Sub senario_0()
    ' _(0)
    End Sub_____________________________________________________________________________________________________________________________________________________________________________________________________________________
    '
    '
    '
    Sub surnario_0()
    ' _(0)
    End Sub_____________________________________________________________________________________________________________________________________________________________________________________________________________________________

    Scenario 1
    ' _(i) Attachment 2141 SirNario_1.JPG . https://imgur.com/zmr2up2
    If no line continuations are present and there is a one or more blank lines, then the line before the first blank line down from the upper routine is taken as the break point.
    No single underscores in any line
    Code:
    Sub Senario_1()
    ' _(i)
    End Sub
    '
    '________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    
    Sub surnaria_1()
    ' _(i)
    End Sub
    '____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    
    ''
    
    '
    Sub Sirnario_1()
    ' _(i)
    End Sub_______________________________________________________________________________________________________________________________________________________________________________________________________________
    
    
    '
    '
    Sub snaria_1()
    ' _(i)
    End Sub

    Scenario 2
    ' _(ii) Attachment 2144 SirNario_2.JPG : https://imgur.com/D2LqloV
    If there are one or more line continuations present then the break point will be placed at the first blank line down after the last line after the line continuation … unless scenario (iii)
    Code:
    Sub Scnari_2()
    ' _(ii)
    End Sub
    
    ''
    '
    ' _
    
    '____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    
    '
    
    Sub Sernario_2()
    ' _(ii)
    End Sub
    '
    '
    ' _
    '
    '___________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    
    '
    Sub Sirnarnio_2()
    ' _(ii)
    End Sub
    Scenario 3
    ' _ (iii) Attachment 2146 SirNario_3.JPG : https://imgur.com/ho56uBN
    There are no blank lines after the first line looking down after the last line continuation looking down, or after the first line looking down after the last line continuation looking down all lines contain comments . In this case, the break is at the line after the line on which the line continuation is on.

    Code:
    Sub scenario_3()
    ' _(iii)
    End Sub
    ''
    ' _
    ____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    '
    '
    Sub SirNario_3()
    ' _(iii)
    End Sub
    
    '
    ' _
    '____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    '
    '
    Sub snuaro_3()
    ' _(iii)
    End Sub
    '
    
    '
    ' _
    ____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    
    
    
    
    
    Sub SirNario_3()
    
    End Sub
    '
    ' _
    '____________________________________________________________________________________________________________________________________________________________________________________________________________________________________
    
    
    
    Sub SurNario_3()
    
    End Sub
    Attached Images Attached Images
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  9. #129
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10

    "What’s in a String"- VBA break down Loop through character contents of a string

    Rotines for this excelfox Thread
    http://www.excelfox.com/forum/showth...0943#post10943

    This is part 1 of the coding. The second part is in the next post. The second part must be copied directly under this part in the same code module

    Code:
    Option Explicit           '
    Option Compare Binary     '     https://docs.microsoft.com/de-de/dotnet/visual-basic/language-reference/statements/option-compare-statement
    
    Sub TestWtchaGot()
    ' In the practice we would likely have our string obtained from some method and would have it held in some string variable
    Dim strTest As String   '                             "Pointer" to a "Blue Print" (or Form, Questionnaire not yet filled in, a template etc.)"Pigeon Hole" in Memory, sufficient in construction to house a piece of Paper with code text giving the relevant information for the particular Variable Type. VBA is sent to it when it passes it. In a Routine it may be given a particular “Value”, or (“Values” for Objects). There instructions say then how to do that and handle(store) that(those). At Dim the created Paper is like a Blue Print that has some empty spaces not yet filled in. A String is a bit tricky. The Blue Print code line Paper in the Pigeon Hole will allow to note the string Length and an Initial start memory Location. This Location well have to change frequently as strings of different length are assigned. Instructions will tell how to do this. Theoretically a special value vbNullString is set to aid in quick checks.. But..http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring-2.html#post44116
     Let strTest = Chr(1) & "Hi" & vbCrLf & vbTab & """u."""
     Call WtchaGot(strIn:=strTest)
    ' Call WtchaGot(Chr(1) & "Hi" & vbCrLf & vbTab & """u.""")
    End Sub
    
    Sub WtchaGot(ByVal strIn As String)
    Rem 1  ' Output "sheet hardcopies"
    '1a) Worksheets     'Make a Temporary Sheet, if not already there, in Current Active Workbook, for a simple list of all characters
        If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then '   ( the '  are not important here, but iin general allow for a space in the worksheet name like  "Wotcha Got In String"
        Dim Wb As Workbook '                                   ' ' Dim:  ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense )                     '
         Set Wb = ActiveWorkbook '  '                            Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want...         Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed.      http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191                                '
         Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
        Dim ws As Worksheet '
         Set ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want...    Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed.      http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191            ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed.      http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
         ws.Activate: ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
         Let ws.Name = "WotchaGotInString"
        Else ' The worksheet is already there , so I just need to set my variable to point to it
         Set ws = ThisWorkbook.Worksheets("WotchaGotInString")
        End If
    '1b) Array
    Dim myLenf As Long: Let myLenf = Len(strIn)  '            ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in.  '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. )       https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
    Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header  Array for the output 2 column list.  The type is known and the size,  but I must use this ReDim  method simply because the dim statement  Dim( , )  is complie time thing and will only take actual numbers
     Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is   " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 20)
    Rem 2  String anylaysis
    'Dim myLenf As Long: Let myLenf = Len(strIn)
    Dim Cnt As Long
        For Cnt = 1 To myLenf ' ===Main Loop========================================================================
        ' Character analysis: Get at each character
        Dim Caracter As Variant ' String is probably OK.
        Let Caracter = Mid(strIn, Cnt, 1) ' '    the character in strIn at position from the left of length 1
        '2a) The character added to a single  WotchaGot  long character string to look at and possibly use in coding
        Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line  required to build the full string of the complete character string
            '2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
            If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
            Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of   "a" & "1" & "2" & "3" &      I would phsically need to write in code  like  strVar = "a" & "1" & "2" & "3"   -  i could of course also write  = "a123"   but the point of this routine is to help me pick out each individual element
            Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf  vbTab
             Select Case Caracter ' 2a)(ii)_1
              Case " "
               Let WotchaGot = WotchaGot & """" & " " & """" & " & "
              Case "!"
               Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
              Case "$"
               Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
              Case "%"
               Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
              Case "~"
               Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
              Case "&"
               Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
              Case "("
               Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
              Case ")"
               Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
              Case "/"
               Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
              Case "\"
               Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
              Case "="
               Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
              Case "?"
               Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
              Case "'"
               Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
              Case "+"
               Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
              Case "-"
               Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
              Case "_"
               Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
              Case "."
               Let WotchaGot = WotchaGot & """" & "." & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

  10. #130
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,452
    Rep Power
    10
    This is the second part of the coding from the last post

    This should be copied and pasted directly under the coding from the last post


    Code:
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '                   ' 2a)(ii)_2
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
    '          Case " "
    '           Let WotchaGot = WotchaGot & """" & " " & """" & " & "
              Case vbCr
               Let WotchaGot = WotchaGot & "vbCr & "  ' I actuall would write manually in this case like     vbCr &
              Case vbLf
               Let WotchaGot = WotchaGot & "vbLf & "
              Case vbCrLf
               Let WotchaGot = WotchaGot & "vbCrLf & "
              Case """"   ' This is how to get a single   "    No one is quite sure how this works.  My theory that,  is as good as any other,  is that  syntaxly   """"    or  "  """  or    """    "   are accepted.   But  in that the  """  bit is somewhat strange for VBA.   It seems to match  the first and Third " together as a  valid pair   but  the other  " in the middle of the  3 "s is also syntax OK, and does not error as    """     would  because  of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the  first  and Third    as a concluding  string pair.  All is well except that  the second  "  is captured   within a   accepted  enclosing pair made up of the first and third  "   At the same time the 4th  "  is accepted as a final concluding   "   paired with the   second which it is  using but at the same time now isolated from.
               Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & "                                ' The reason why  ""  ""   would not work is that    at the end of the  "" the next empty  character signalises the end of a  string pair, and only if  it saw a " would it keep checking the syntax rules which  then lead in the previous case to  the situation described above.
              Case vbTab
               Let WotchaGot = WotchaGot & "vbTab & "
              ' 2a)(iii)
                Case Else
                 WotchaGot = WotchaGot & "Chr(" & Asc(Caracter) & ")" & " & "
                'Let CaseElse = Caracter
            End Select
            End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
        '2b)  A 2 column Array for convenience of a list
         Let arrWotchaGot(Cnt + 1, 1) = Cnt & "           " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = Asc(Caracter) ' +1 for header
        Next Cnt ' ========Main Loop=================================================================================
        If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & "    ( 2 spaces one either side of a  & )
    Rem 3 Output
    '3a) String
    MsgBox prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
    '3b) List
    Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next  If  this prevents the first column beine taken as 0 for an empty worksheet
     If Not ws.Range("A1").Value = "" Then Let NxtClm = ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
     Let ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
    End Sub
    '
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

Similar Threads

  1. Testing Concatenating with styles
    By DocAElstein in forum Test Area
    Replies: 2
    Last Post: 12-20-2020, 02:49 AM
  2. testing
    By Jewano in forum Test Area
    Replies: 7
    Last Post: 12-05-2020, 03:31 AM
  3. Replies: 18
    Last Post: 03-17-2019, 06:10 PM
  4. Concatenating your Balls
    By DocAElstein in forum Excel Help
    Replies: 26
    Last Post: 10-13-2014, 02:07 PM
  5. Replies: 1
    Last Post: 12-04-2012, 08:56 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •