Appendix Thread. ( Codes for other Threads, etc.) Event Coding Drpdown Data validation

**DocAElstein** · 12-24-2018, 01:16 PM

Routine for following excelfox Thread
http://www.excelfox.com/forum/showth...0865#post10865

Code:

Sub TestieCall()
 Call PubeProFannyTeas__GLetner("23 12 2018")
End Sub
Sub PubeProFannyTeas__GLetner(ByVal strDte As String)
Rem 0 VBA project instantiated VBIDE
Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module
 Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodule                                                 ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module
Rem 1 This code module data range
'1a) get full data range as string
Dim Cnt As Long, Lr As Long, ReedLineIn As String
 Let Lr = VBIDEVBAProj.countoflines: Let Cnt = Lr + 1
    Do
     Let Cnt = Cnt - 1
     Let ReedLineIn = VBIDEVBAProj.Lines(StartLine:=Cnt, Count:=1)
    Loop While Not (Left(ReedLineIn, 7) = "End Sub" Or Left(ReedLineIn, 7) = "End Fun")
    If Cnt = Lr Then MsgBox Prompt:="No range data values in code module  " & VBIDEVBAProj.Name: Exit Sub
'1b) Complete data region as single string.
Dim strIn As String: Let strIn = VBIDEVBAProj.Lines(StartLine:=Cnt + 1, Count:=Lr - Cnt)
 Let strIn = Mid(strIn, 3) ' take off first vbCr & vbLf
 'WotchaGot (strIn)
'1c) split into date ranges, get most recent of any dates to match given  strDte
Dim DtedRngs() As String: Let DtedRngs() = Split(strIn, vbCr & vbLf & vbCr & vbLf) ' Split range by empty line which is double  vbCr & vbLf
 'WotchaGot (DtedRngs(0)): Debug.Print: WotchaGot (DtedRngs(1))
    For Cnt = UBound(DtedRngs()) To LBound(DtedRngs()) Step -1
    '1d)Check for date match, if so the main code working begins
        Dim FndDte As String: Let FndDte = Mid(DtedRngs(Cnt), 4, 10) ' looking at like this typical start of a data range,    '_-23 12 2018 Wo....  we see that 10 characters from character 4 will give us the date
        If FndDte = strDte Then
         'MsgBox Prompt:=FndDte
        Rem 2 manipulation of found date range
        Dim strRng As String: Let strRng = DtedRngs(Cnt)
         Let strRng = Mid(strRng, 27) 'takes off up to start of worksheet name... no speacial reason toher than why not? - its not needed anymore
        '2a) range info
        Dim RngInfo As String: Let RngInfo = Left(strRng, InStr(1, strRng, """)" & vbCr & vbLf, vbBinaryCompare) - 1) '    This gets us at like        Tabelle1").Range("$I$2513:$J$2514
        Dim ShtName As String, RngAdrs As String
         Let ShtName = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(0) '    split above string ,  using as seperator  ").Range("   ,  into 2 bits   ,   for exact computer binary type compare     Then we have first array element (indicie (0)) as the worksheet name  and the second array element (indicie (1)) as the range address
         Let RngAdrs = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(1) ': Debug.Print ShtName & "  " & RngAdrs
        Dim Ws As Worksheet, Rng As Range: Set Ws = Worksheets("" & ShtName & ""): Set Rng = Ws.Range(RngAdrs)
        '2b) get data value range
         Let strRng = Mid(strRng, InStr(1, strRng, vbCr & vbLf, vbBinaryCompare) + 2) ' take off first line & the first vbCr & vbLf
         Let strRng = Left(strRng, InStr(1, strRng, "'_- EOF ", vbBinaryCompare) - 1) ' take off last line, ( but leave on the vbCr & vbLf as that seems to typically be on a string from an excel range
         'WotchaGot strRng
         Let strRng = Replace(strRng, " | ", vbTab, 1, -1, vbBinaryCompare) 'Change code window cell wall seperator for that used by Excel
         Let strRng = Replace(strRng, "'_-", "", 1, -1, vbBinaryCompare)
         Let strRng = Replace(strRng, "  ", "", 1, -1, vbBinaryCompare) ' Bit of bodge to remove my added spaces
         'Debug.Print strRng
        Rem 3 output to worksheet
        Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): objDataObject.SetText strRng: objDataObject.PutInClipboard ' Text is given to Data object which in turn uses its method to put that in the clipboard
         Ws.Paste Destination:=Rng 'Worksheets Paste method with optional argument to determine where, ( default would be from top left of active range )
         Exit Sub 'This code only gets the first found range looking from code window bottom
        Else '     No matching date found yet, so do nothing but
        End If '    go on to
    Next Cnt '    next date range ' ( There is no check for no matching date. The code will simple end after all ranges have been looped through.)
End Sub