Page 13 of 30 FirstFirst ... 3111213141523 ... LastLast
Results 121 to 130 of 294

Thread: Appendix Thread. ( Codes for other Threads, ( Avinash ).)

  1. #121
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    Test draft copy of forum answers associated with lates XP updates issues

    http://www.eileenslounge.com/viewtop...249846#p249846
    https://social.technet.microsoft.com...eitproprevious
    https://tinyurl.com/t73r3pg
    https://social.technet.microsoft.com...?forum=outlook
    ( ( Locked Threads:
    https://answers.microsoft.com/en-us/...lc=1031&page=6
    https://answers.microsoft.com/en-us/...fb63739&page=4
    https://answers.microsoft.com/en-us/...16500c3?page=1
    https://answers.microsoft.com/en-us/...2-7df17e82fb3d )
    )

    I just finished unwrapping my Xmas present from Microsoft. It took me a couple of days. Despite having automatic updates disabled, occasionally a massive amount of updates still come down unexpectedly. It does not happen very often. I think theoretically it should never happen. But it does.

    So one of my XP machines got the present.
    I do have an extensive library of known "good and bad" Updates, and coding to sort through and compare them etc.. That usually helps identify the culprits. This time it only saw the old favourites that Microsoft like to send to cripple Active X controls, but never the less my XP was crippled by the issues discussed in this Thread.

    I did identify some new updates that I had not seen before, but de installing them did not solve the problem , at least initially. After a lot of painstaking manual de installing and re installing updates I sorted the problem out…

    It was very strange this time. By removing recent updates, I noticed that other updates suddenly appeared in the update this. They were not visible before. After removing some of those , the XP problem was solved. Furthermore I could re install most of the updated which I had originbally removed and still the XP problem does not return

    Just to explain that again: In order to find the killer updates, you first have to de install some non offending updates. Only then do the killer updates show so that you can de install them. (A few other harmless updates may also suddenly appear). Then you can put the others back, if you like.

    So finally below is the current list, with the recent ones at the bottom

    If you don't find those,
    or
    you find some, de install them,
    and still have the problem,
    then try de installing a few other recent updates and then look at your update list again . If you then see any of the bad updates , then de install them. If that cures the problem then you may be able to re install some of the others you de installed without getting the problem.

    In actual fact in my recent case, following the procedure that I have described, I now have all the updates that were showing after the unwanted Xmas present, and a few more, but I no longer have the problem, because I have de installed some of the bad updates, which were initially not showing after the unwanted present. Crazy situation!

    Current Killer List
    KB4461522 ( no longer available )
    KB4461614 ( available , but not been offered for some time )
    KB4462157 ( available , but not been offered for some time. ( Originally this was introduced to solve the problem. It never did. Quite the opposite: If you have the problem, then installing this update has no effect; but if you do not have the problem , and you instal this update, it causes the problem, just as all the other "killers do !!. ) )
    KB4462174 ( available, and until recently, was still offered )
    KB4462223
    KB4464566 Probably the most recent killer
    The last two may be hidden , and you may need to go through the steps I described to find them. Unfortunately I still have not figured out how to automate messing around with Office updates in XP ( I can do it with most everything else ). So you will need a few days to unwrap your present if you get one…




    (P.s. Microsoft have locked some Threads on this, making it difficult to update people on the problem. But a few new Threads have also been started)

    Ref:
    https://social.technet.microsoft.com...eitproprevious
    https://tinyurl.com/t73r3pg
    https://social.technet.microsoft.com...?forum=outlook
    Locked Threads:
    https://answers.microsoft.com/en-us/...lc=1031&page=6
    https://answers.microsoft.com/en-us/...fb63739&page=4
    https://answers.microsoft.com/en-us/...16500c3?page=1
    https://answers.microsoft.com/en-us/...2-7df17e82fb3d

  2. #122
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    In support of these Thread posts

    http://www.excelfox.com/forum/showth...ll=1#post11015
    http://www.eileenslounge.com/viewtop...262344#p262344




    Code:
    Sub TestWtchaGot_Unic_NotMuchIfYaChoppedItOff()
     Call WtchaGot_Unic_NotMuchIfYaChoppedItOff("Laptop" & ChrW(8207) & ChrW(5))
    End Sub
    Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(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, 40)
    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
                'SirNirios
                If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a  "normal"  character
                    If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then  ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
                     Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
                    Else
                    End If
                Else
                End If
            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 & """" & " " & """" & " & "
    '          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 vbNewLine
               Let WotchaGot = WotchaGot & "vbNewLine & "
              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
                    If AscW(Caracter) < 256 Then
                     Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
                    Else
                     Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
                    End If
                '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) = AscW(Caracter) ' +1 for header
        Next Cnt ' ========Main Loop=================================================================================
        '2c) Some tidying up
        If WotchaGot <> "" Then
         Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & "    ( 2 spaces one either side of a  & )
         Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
         ' The next bit changes like this  "Lapto" & "p"  to  "Laptop"   You might want to leave it out ti speed things up a bit
            If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
             Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) '  Changes like this  "Lapto" & "p"  to  "Laptop"
            Else
            End If
        Else
        End If
    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()
     Ws.Cells.Columns.AutoFit
    End Sub
    '

  3. #123
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    Coding for this Thread post
    http://www.excelfox.com/forum/showth...ll=1#post11827


    Code:
    Sub MakeFormulas4() '  http://www.excelfox.com/forum/showthread.php/2390-Apply-Vlookup-formula-in-all-the-available-sheets-in-a-workbook?p=11827&viewfull=1#post11827
    Rem 1 '  Workbooks info
    ' 1a This months book, this workbook. It is the outout book for the current month
    Dim ThisMonthsLatestBook As Workbook, LisWbName As String
     Set ThisMonthsLatestBook = ThisWorkbook ' ActiveWorkbook
     Let LisWbName = ThisMonthsLatestBook.Name
    '    If InStr(7, LisWbName, Format(Now(), "MMM"), vbTextCompare) = 0 Then MsgBox Prompt:="This workbook is not for " & Format(Now(), "MMMM"): Exit Sub
    'Dim BookN As Long
    ' Let BookN = Mid(LisWbName, 5, InStr(5, LisWbName, "_", vbBinaryCompare) - 5)
    ' 1b Last months book
    Dim strDteLisBk As String, DteLisBk As Date
     Let strDteLisBk = Mid(LisWbName, 32, 8)
    Dim LooksLikeADate As String: Let LooksLikeADate = Right(strDteLisBk, 2) & "." & Mid(strDteLisBk, 5, 2) & "." & Left(strDteLisBk, 4)
     Let DteLisBk = CDate(LooksLikeADate) '  31.12.2019  Looks like a date
    
    Dim sourceBookName As String
    ' Let sourceBookName = "Book" & BookN - 1 & "_" & Format(DateAdd("m", -1, Now()), "MMM YYYY") & ".xlsm"
      Let sourceBookName = "MSCI Equity Index Constituents " & Format(DateAdd("m", -1, DteLisBk), "YYYYMMDD") & ".xlsm"
    Dim sourceBook As Workbook
     Set sourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & sourceBookName)
    Rem 2  Make records worksheet                                                                  Sub MakeWorkSheetIfNotThere()
    '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                                '
         If Not Evaluate("=ISREF(" & "'" & "Records" & "'!Z78)") Then '   ( the '  are not important here, but in general allow for a space in the worksheet name like  "My Records"
         ThisMonthsLatestBook.Worksheets.Add After:=ThisMonthsLatestBook.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
        Dim wsRcds As Worksheet '
         Set wsRcds = ThisMonthsLatestBook.Worksheets.Item(ThisMonthsLatestBook.Worksheets.Count)        '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
         wsRcds.Activate: wsRcds.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
         Let wsRcds.Name = "Records"
        Else ' The worksheet is already there , so I just need to set my variable to point to it
         Set wsRcds = ThisWorkbook.Worksheets("Records")
        End If
    '                                                                                               End Sub
    Rem 3 looping through worksheets
    Dim C As Long, I As Long
    'C = ActiveWorkbook.Worksheets.Count
     'Let C = ThisWorkbook.Worksheets.Count
     Let C = ThisMonthsLatestBook.Worksheets.Count - 1  '   -1 since last worksheet is records worksheet
        'For I = 1 To C
    'Application.ScreenUpdating = True
        For I = 1 To C   '   Sheet1  , Sheet2   , Sheet3 .......
        'what are  our worksheets?                         I   =  1        ,       2 ,      3    ..........
        Dim sourceSheet As Worksheet
         Set sourceSheet = sourceBook.Worksheets.Item(I) '     ("Sheet1")  , Sheet2   , Sheet3 ........
        Dim outputSheet As Worksheet
         Set outputSheet = ThisWorkbook.Worksheets.Item(I) ' ("Sheet1")    , Sheet2   , Sheet3 ........
           
            'Determine last row of source
            With sourceSheet
            Dim SourceLastRow As Long
             SourceLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            End With
            With outputSheet
            'Determine last row in col P
            Dim OutputLastRow As Long
             OutputLastRow = .Cells(.Rows.Count, "P").End(xlUp).Row
            End With
            'Apply our formula in records worksheet
            With Worksheets("Records")
             Let .Cells.Item(1, I).Value = sourceSheet.Name   '  Header in column as worksheet name
             '.Range("Q2:Q" & OutputLastRow).Formula = "=VLOOKUP($A2,'[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
             .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = "=VLOOKUP(" & outputSheet.Name & "!$A2,'" & sourceBook.Path & "\" & "[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
    '        .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value
            End With
         'MsgBox ActiveWorkbook.Worksheets(I).Name
         MsgBox ActiveWorkbook.Worksheets.Item(I).Name
        Next I
    'Next P
    Rem 4
    Dim cel As Range
        With Worksheets("Records").UsedRange
            For Each cel In .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                If IsError(cel.Value) Then
                '
                Else
                    If cel.Value < 3 Then
                     cel.Font.Color = vbRed
                    Else
                     cel.Font.Color = vbGreen
                    End If
                End If
            Next cel
        End With
        
    'Close the source workbook, don't save any changes
     sourceBook.Close False
    ' Application.ScreenUpdating = True
    End Sub

  4. #124
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    Coding in support of these Thread posts
    http://www.excelfox.com/forum/showth...ll=1#post11569
    http://www.excelfox.com/forum/showth...ll=1#post11672




    Code:
    
    Sub ipconfigall_routeprint(Optional ByVal Msg As String) '
    Rem 1 ipconfig /all
     Shell "cmd.exe /c ""ipconfig /all > """ & ThisWorkbook.Path & "\ipconfig__all.txt"""""
    ' Get the entire text file as a string
    Dim FileNum As Long: Let FileNum = FreeFile(1) '
    Dim PathAndFileName As String, strIPcon As String
     Let PathAndFileName = ThisWorkbook.Path & "\ipconfig__all.txt"
     ' Let PathAndFileName = ThisWorkbook.Path & "\test2B.txt"  '  Al
      Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
        strIPcon = VBA.Strings.Space$(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
        Get #FileNum, , strIPcon
      Close #FileNum
    ' Tidy the string
     Let strIPcon = Replace(strIPcon, vbCr & vbCr, vbCr, 1, -1, vbBinaryCompare)
     Let strIPcon = Replace(strIPcon, vbTab, "   ", 1, -1, vbBinaryCompare)
    ' add any extra info to string
    Dim PublicIP As String: Call PubicIP(PublicIP)
      Let strIPcon = "ipconfig /all   route print" & Msg & vbCr & vbLf & ComputerName & vbCr & vbLf & GetIpAddrTable & vbCr & vbLf & PublicIP & vbCr & vbLf & vbCr & vbLf & """" & Format(Now, "DD MMM YYYY") & " " & vbLf & " " & Format(Now, "hh mm ss") & """" & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & strIPcon        ' vbLf is recognised as a new line within an Excel"
    ' String content check
    ' Call WtchaGot(strIPcon)
    ' put the text in the clipboard
    Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    objDataObject.SetText strIPcon: objDataObject.PutInClipboard
    
    ' Excel Worksheet
    Dim Ws As Worksheet: Set Ws = ActiveSheet
    Dim Clm As Range, NxtClm As Long
     Set Clm = Ws.Cells.Find(What:="*", After:=Ws.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
        If Clm Is Nothing Then
         Let NxtClm = 2
        Else
         Let NxtClm = Clm.Column + 1
        End If
    ' Put in next free column in Active sheet
     Ws.Paste Destination:=Ws.Cells.Item(1, NxtClm)
    ' Ws.Columns.AutoFit: Ws.Rows.AutoFit
    
    Rem 2 route print
     Shell "cmd.exe /c ""route print > """ & ThisWorkbook.Path & "\route_print.txt"""""
    ' Get the entire text file as a string
     Let FileNum = FreeFile(1) '              ' The "highway/ street/ link" to be built to transport the text will be given a number. It must be unique. So we use for convenience, the Freefile function: it returns an integer that represents the next file number that the Open statement can use.  The optional argument for the range number is a variant that is used to specify a range from which the next free file number is returned. Enter a value of data type 0 (default) to return a file number in the range 1 - 255 inclusive. Enter 1 to return a file number in the range 256 - 511.   https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/freefile-function  . Note also : Use file numbers in the range 1-255, inclusive, for files not accessible to other applications. Use file numbers in the range 256-511 for files accessible from other applications
    Dim strrouteprint As String
     Let PathAndFileName = ThisWorkbook.Path & "\route_print.txt"
     ' Let PathAndFileName = ThisWorkbook.Path & "\test2B.txt"  '  Al
      Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
        strrouteprint = VBA.Strings.Space$(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
        Get #FileNum, , strrouteprint
      Close #FileNum
    ' Tidy the string
     Let strrouteprint = Replace(strrouteprint, vbCr & vbCr, vbCr, 1, -1, vbBinaryCompare)
     Let strrouteprint = Replace(strrouteprint, vbTab, "   ", 1, -1, vbBinaryCompare)
    ' put the text in the clipboard
    objDataObject.SetText strrouteprint: objDataObject.PutInClipboard
    ' Excel Worksheet
    Dim Lr As Long: Let Lr = Ws.Cells(Ws.Rows.Count, NxtClm).End(xlUp).Row
    ' Put in next free column in Active sheet
     Ws.Paste Destination:=Ws.Cells.Item(Lr + 30, NxtClm)
     Ws.Columns.AutoFit: Ws.Rows.AutoFit
     ActiveWindow.Panes(2).Activate
     Ws.Cells.Item(1, NxtClm).Select
    End Sub
    '

  5. #125
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    In support of this Thread
    http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
    http://www.excelfox.com/forum/showth...iple-Criterias


    Summary worksheet, before

    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    A
    B
    C
    D
    1
    Voucher Date Link
    2
    Go To Sheet
    3
    Go To Sheet
    4
    Worksheet: Summary

  6. #126
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    In support of this Thread
    http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
    http://www.excelfox.com/forum/showth...iple-Criterias


    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    01.01.2020_99909900 - A 01.01.2020_88888888 - F 01.01.2020_88888886 - D 01.01.2020_88888887 - E 02.01.2020_99909900 - A 03.01.2020_99909900 - A 04.01.2020_88888888 - F 05.01.2020_88888888 - F 06.01.2020_88888888 - F 07.01.2020_88888888 - F 08.01.2020_88888888 - F 09.01.2020_88888888 - F 10.01.2020_99909900 - A 11.01.2020_99909900 - A 12.01.2020_99909900 - A 13.01.2020_99909900 - A 14.01.2020_99909900 - A 15.01.2020_99909900 - A
    Worksheet: arrUnicDtsSrc

  7. #127
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    In support of this Thread
    http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
    http://www.excelfox.com/forum/showth...iple-Criterias



    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    01.01.2020 1 Item A ABC123 1 2000 2000 1E+08 A 1 2000 2000 01.01.2020_99909900 - A
    01.01.2020 4 Item D LLL000 1 131 131 1E+08 A 1 131 131 01.01.2020_99909900 - A
    01.01.2020 5 Item E LLL000 5 550 2750 1E+08 A 5 550 2750 01.01.2020_99909900 - A
    01.01.2020 1 Item A ABC123 1 2000 2000 1E+08 A 1 2000 2000 01.01.2020_99909900 - A
    01.01.2020 4 Item D LLL000 1 131 131 1E+08 A 1 131 131 01.01.2020_99909900 - A
    01.01.2020 5 Item E LLL000 5 550 2750 1E+08 A 5 550 2750 01.01.2020_99909900 - A
    01.01.2020 1 Item A ABC123 1 2000 2000 1E+08 A 1 2000 2000 01.01.2020_99909900 - A
    01.01.2020 4 Item D LLL000 1 131 131 1E+08 A 1 131 131 01.01.2020_99909900 - A
    01.01.2020 5 Item E LLL000 5 550 2750 1E+08 A 5 550 2750 01.01.2020_99909900 - A
    01.01.2020 1 Item A ABC123 1 2000 2000 1E+08 A 1 2000 2000 01.01.2020_99909900 - A
    01.01.2020 4 Item D LLL000 1 131 131 1E+08 A 1 131 131 01.01.2020_99909900 - A
    01.01.2020 5 Item E LLL000 5 550 2750 1E+08 A 5 550 2750 01.01.2020_99909900 - A
    01.01.2020 1 Item A ABC123 1 2000 2000 1E+08 A 1 2000 2000 01.01.2020_99909900 - A
    01.01.2020 4 Item B LLL000 1 131 131 8.9E+07 F 1 131 131 01.01.2020_88888888 - F
    01.01.2020 5 Item C LLL000 5 550 2750 8.9E+07 F 5 550 2750 01.01.2020_88888888 - F
    01.01.2020 1 Item D ABC123 1 2000 2000 8.9E+07 D 1 2000 2000 01.01.2020_88888886 - D
    01.01.2020 4 Item D LLL000 1 131 131 8.9E+07 E 1 131 131 01.01.2020_88888887 - E
    01.01.2020 5 Item E LLL000 5 550 2750 8.9E+07 F 5 550 2750 01.01.2020_88888888 - F
    01.01.2020 1 Item A ABC123 1 2000 2000 1E+08 A 1 2000 2000 01.01.2020_99909900 - A
    01.01.2020 4 Item D LLL000 1 131 131 1E+08 A 1 131 131 01.01.2020_99909900 - A
    01.01.2020 5 Item E LLL000 5 550 2750 1E+08 A 5 550 2750 01.01.2020_99909900 - A
    01.01.2020 1 Item A ABC123 1 2000 2000 1E+08 A 1 2000 2000 01.01.2020_99909900 - A
    01.01.2020 4 Item D LLL000 1 131 131 1E+08 A 1 131 131 01.01.2020_99909900 - A
    01.01.2020 5 Item E LLL000 5 550 2750 1E+08 A 5 550 2750 01.01.2020_99909900 - A
    02.01.2020 2 Item B ABC122 1 3500 3500 1E+08 A 1 3500 3500 02.01.2020_99909900 - A
    03.01.2020 3 Item C LLL000 4 10.4 41.6 1E+08 A 4 10.4 41.6 03.01.2020_99909900 - A
    04.01.2020 4 Item D LLL001 1 131 131 8.9E+07 F 1 131 131 04.01.2020_88888888 - F
    05.01.2020 5 Item E ABC999 8 550 4400 8.9E+07 F 8 550 4400 05.01.2020_88888888 - F
    06.01.2020 6 Item F ABC999 1 2500 2500 8.9E+07 F 1 2500 2500 06.01.2020_88888888 - F
    07.01.2020 7 Item G LLL001 1 2500 2500 8.9E+07 F 1 2500 2500 07.01.2020_88888888 - F
    08.01.2020 8 Item H LLL001 1 2250 2250 8.9E+07 F 1 2250 2250 08.01.2020_88888888 - F
    09.01.2020 4 Item D ABC123 1 2250 2250 8.9E+07 F 1 2250 2250 09.01.2020_88888888 - F
    10.01.2020 5 Item E ABC122 1 2250 2250 1E+08 A 1 2250 2250 10.01.2020_99909900 - A
    11.01.2020 11 Item K ABC122 1 600 600 1E+08 A 1 600 600 11.01.2020_99909900 - A
    12.01.2020 12 Item L ABC123 1 4992 4992 1E+08 A 1 4992 4992 12.01.2020_99909900 - A
    13.01.2020 13 Item M ABC122 1 10 10 1E+08 A 1 10 10 13.01.2020_99909900 - A
    14.01.2020 6 Item F LLL000 1 2731 2731 1E+08 A 1 2731 2731 14.01.2020_99909900 - A
    15.01.2020 7 Item G ABC122 1 85000 85000 1E+08 A 1 85000 85000 15.01.2020_99909900 - A
    01.01.2020 5 Item E LLL000 5 550 2750 1E+08 A 5 550 2750 01.01.2020_99909900 - A
    02.01.2020 2 Item B ABC122 1 3500 3500 1E+08 A 1 3500 3500 02.01.2020_99909900 - A
    03.01.2020 3 Item C LLL000 4 10.4 41.6 1E+08 A 4 10.4 41.6 03.01.2020_99909900 - A
    04.01.2020 4 Item D LLL001 1 131 131 8.9E+07 F 1 131 131 04.01.2020_88888888 - F
    05.01.2020 5 Item E ABC999 8 550 4400 8.9E+07 F 8 550 4400 05.01.2020_88888888 - F
    06.01.2020 6 Item F ABC999 1 2500 2500 8.9E+07 F 1 2500 2500 06.01.2020_88888888 - F
    07.01.2020 7 Item G LLL001 1 2500 2500 8.9E+07 F 1 2500 2500 07.01.2020_88888888 - F
    08.01.2020 8 Item H LLL001 1 2250 2250 8.9E+07 F 1 2250 2250 08.01.2020_88888888 - F
    09.01.2020 4 Item D ABC123 1 2250 2250 8.9E+07 F 1 2250 2250 09.01.2020_88888888 - F
    10.01.2020 5 Item E ABC122 1 2250 2250 1E+08 A 1 2250 2250 10.01.2020_99909900 - A
    11.01.2020 11 Item K ABC122 1 600 600 1E+08 A 1 600 600 11.01.2020_99909900 - A
    12.01.2020 12 Item L ABC123 1 4992 4992 1E+08 A 1 4992 4992 12.01.2020_99909900 - A
    13.01.2020 13 Item M ABC122 1 10 10 1E+08 A 1 10 10 13.01.2020_99909900 - A
    Worksheet: arrAllDts

  8. #128
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    In support of this Thread
    http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
    http://www.excelfox.com/forum/showth...iple-Criterias







    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    4 5 6 7 8 9 10 11 12 13 14 15 16 22 23 24 25 26 27 42
    Worksheet: arrRws









    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    22
    23
    24
    25
    26
    27
    42
    Worksheet: arrRwsT

  9. #129
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    In support of this Thread
    http://www.excelfox.com/forum/showthread.php/2402-Extract-Multiple-Rows-into-a-Limited-Template-based-on-Multiple-Criterias
    http://www.excelfox.com/forum/showth...iple-Criterias



    Code:
    Option Explicit
    Sub DoItForADay()
    Rem 1 Worksheets info
    Dim WsTp As Worksheet, WsDta As Worksheet, WsSmry As Worksheet
     Set WsTp = ThisWorkbook.Worksheets("Template"): Set WsDta = ThisWorkbook.Worksheets("Datadump"): Set WsSmry = ThisWorkbook.Worksheets("Summary")
    Rem 2 The days and source list
    ' 2a) Put all info in an array
    Dim LrDta As Long: Let LrDta = WsDta.Range("A" & WsDta.Rows.Count & "").End(xlUp).Row
    Dim arrAllDts() As Variant           '  In the naxt line, the  .Value  Property ( method ) , is used to return in one go all  Values  in the range.  They are returned as a field, ( array ) of values in  held in  Variant  type  elements.  So we must use Variant for the  Dim ing  of the type of our Elements, or else the next code line will error , with a  Mismatch error
     Let arrAllDts = WsDta.Range("A4:M" & LrDta & "").Value '  I am adding  column M  for my own amusement
    ' 2b)
    
    ' 2c) make an array with all unique identifier for each voucher
    Dim Cnt As Long
        For Cnt = 1 To UBound(arrAllDts(), 1) ' Looping effectively from forth row until last row in  Datadump
    Dim Idt As String
         Let Idt = arrAllDts(Cnt, 1) & "_" & arrAllDts(Cnt, 8) & " - " & arrAllDts(Cnt, 9) '  I am adding a  "_"  to in between the   date   and   source info  : Later I can split the   unique identifiers  string by this  "_"  in order to get the date and souce info
         Let arrAllDts(Cnt, 13) = Idt
        Dim strDtsSrc As String
            If InStr(1, strDtsSrc, Idt, vbBinaryCompare) = 0 Then
             Let strDtsSrc = strDtsSrc & Idt & "###"
            Else
            ' case we already have the date in our string,  strDts
            End If
        Next Cnt
     Let strDtsSrc = Left(strDtsSrc, (Len(strDtsSrc) - 3)) '  take off the last space  "###"  which we do not need
     'Debug.Print strDtsSrc
    ' 2d)
    Dim arrUnicDtsSrc() As String
     Let arrUnicDtsSrc() = Split(strDtsSrc, "###", -1)
     Let Worksheets("arrUnicDtsSrc").Range("A1").Resize(1, (UBound(arrUnicDtsSrc()) + 1)).Value = arrUnicDtsSrc()      '    arrUnicDtsSrc().jpg  --- https://imgur.com/QX1bJMB
     Worksheets("arrUnicDtsSrc").Columns.AutoFit
     Let Worksheets("arrAllDts").Range("A4:M" & LrDta & "").Value = arrAllDts()
     ' The next code line can be removed to get all the 19 worksheets
     ReDim arrUnicDtsSrc(0 To 0): Let arrUnicDtsSrc(0) = "01.01.2020_99909900 - A" ' ***** I am limiting it to the first unique identifier, ( 01.01.2020_99909900 - A ) just for demo purposes. If you remove this line,  then you will see that all dates and sources  will be considered
    Rem 3                               ' === Main Outer loop ============================================================
    Dim Stear As Variant    '   For Each  unique identifier  . In VBA,
        For Each Stear In arrUnicDtsSrc() ' Doing stuff For Each  unique identifier
        '3a) work out how many rows and which row indicies with the current unique identifier
        Dim DteSrcRwCnt As Long
            For Cnt = 1 To UBound(arrAllDts(), 1) ' ----------------------Going through all data rows
             If arrAllDts(Cnt, 13) = CStr(Stear) Then ' I am looking for rows in the main datadump that have the current unique identifier
            '3a)(i) counting rows
                                                                               ' Debug.Print Cnt + 3 & " " & arrAllDts(Cnt, 13)
              Let DteSrcRwCnt = DteSrcRwCnt + 1  '  counting the rows for the current unique identifier
             '3a)(ii) get the (row) indicies for the current unique identifier. Later i need the row number of all the rows corresponding to the current unique identifier
             Dim strRws As String
              Let strRws = strRws & Cnt + 3 & " " ' I later wont the actual row in the datadump worksheet, so that is 3 higher than the "row" number in  arrAllDts()  because I captured just the range from the 4th row  --    "A4:M........
             Else
             End If
            Next Cnt                              ' ----------------------Going through all data rows
         Let strRws = Left(strRws, (Len(strRws) - 1))   ' Take of last  " "  which I do not need
        Dim arrRws() As String ' The VBA string function returns field of string type elements. So I must Dim my array elements appropriately
         Let arrRws() = Split(strRws, " ", -1, vbBinaryCompare) ' This gives us an array which is the row numbers  in the  Datadump  for this unique identifier
         Let ThisWorkbook.Worksheets("arrRws").Range("A1").Resize(1, (UBound(arrRws()) + 1)).Value = arrRws() '   arrRws().JPG - https://imgur.com/HDgpyQq                          -
         ThisWorkbook.Worksheets("arrRws").Columns.AutoFit
        '3b) In the  "Magic Code line"  below we need a  "vertical" array     https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
        Dim arrRwsT() As Long
         ReDim arrRwsT(1 To UBound(arrRws()) + 1, 1 To 1) ' a  "Vertical"  1 column array
            For Cnt = 1 To UBound(arrRws()) + 1
             Let arrRwsT(Cnt, 1) = arrRws(Cnt - 1)
            Next Cnt
        Let ThisWorkbook.Worksheets("arrRwsT").Range("A1:A" & UBound(arrRws()) + 1 & "").Value = arrRwsT()  '                             -         arrRwsT().JPG - https://imgur.com/syf0PaZ
        Rem 4 Make Vouchers for current unique identifier, Stear
        ' 4a)
        Dim arrVouch() As Variant    '     https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
         Let arrVouch() = WsTp.Range("A1:K24").Value
        ' 4b) An array just containing the rows for the current Idt
        Dim Clms() As Variant: Let Clms() = Evaluate("=Column(A:N)")    '   {1, 2, 3, 4......14} -   Clms().jpg  -  https://imgur.com/xHlUeH9
        Dim arrDtsSrc() As Variant  '    For   "Magic Code line"     https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
         Let arrDtsSrc() = Application.Index(WsDta.Cells, arrRwsT(), Clms())  ' - --"Magic Code line"      -  arrDtsSrc().JPG : https://imgur.com/0c8SgIn
         Let ThisWorkbook.Worksheets("arrDtsSrc").Range("A1").Resize(UBound(arrDtsSrc(), 1), UBound(arrDtsSrc(), 2)).Value = arrDtsSrc() '                             -         arrRwsT().JPG - https://imgur.com/syf0PaZ
        Dim RwCnt As Long: Let RwCnt = 1: Let Cnt = 1
        ' 4c)
            Do While RwCnt < DteSrcRwCnt + 1 ' ............................................
                Do While Cnt < 11 ' _________________________________|
                 '   Fill in values in Voucher Array
                 Let arrVouch(Cnt + 9, 1) = "'" & arrDtsSrc(RwCnt, 2)   '  The extra   "'"   is one way to keep the leading 0s
                 Let arrVouch(Cnt + 9, 4) = arrDtsSrc(RwCnt, 3)    '   Detail  ( Item )
                 Let arrVouch(Cnt + 9, 7) = arrDtsSrc(RwCnt, 4)    '   Unit Code
                 Let arrVouch(Cnt + 9, 9) = arrDtsSrc(RwCnt, 11)    '   Value
                 Let Cnt = Cnt + 1
                 Let RwCnt = RwCnt + 1
                Loop ' While Cnt < 11 ' ______________________________|
             Let arrVouch(6, 3) = Split(Stear, "_", 2, vbBinaryCompare)(1) ' The second array element (1) is  source code & source name  ( The first array element (0) is the date )
             Let arrVouch(4, 10) = Split(Stear, "_", 2, vbBinaryCompare)(0) ' The first array element (0) is the date
             Let Cnt = 1                       ' back to first row for a template
         '4d) Information to the summary sheet.
            Dim NxtVch As Long: Let NxtVch = WsSmry.Range("A" & WsSmry.Rows.Count & "").End(xlUp).Row
             Let WsSmry.Range("A" & NxtVch + 1 & "").Value = "V" & Format(NxtVch, "0000")
             Let WsSmry.Range("B" & NxtVch + 1 & "").Value = Split(Stear, "_", 2, vbBinaryCompare)(0)
             WsSmry.Hyperlinks.Add Anchor:=WsSmry.Range("C" & NxtVch + 1 & ""), Address:="", SubAddress:="V" & Format(NxtVch, "0000") & "!A1", TextToDisplay:="Go To Sheet"
         '4e)  Add next voucher
             WsTp.Copy After:=WsDta
             Let ActiveSheet.Name = "V" & Format(NxtVch, "0000")
             Let ThisWorkbook.Worksheets("arrVouch").Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch() '                             -         arrRwsT().JPG - https://imgur.com/syf0PaZ
             Let ActiveSheet.Range("A1").Resize(UBound(arrVouch(), 1), UBound(arrVouch(), 2)).Value = arrVouch()
             Let arrVouch() = WsTp.Range("A1:K24").Value  ' get a new template array
        
            Loop ' While RwCnt < DteSrcRwCnt ' .............................................
    
         Let DteSrcRwCnt = 0 ' ready for next Idt Stear
        Next Stear         ' === Main Outer loop =========================================================================
    
    End Sub
    Attached Files Attached Files

  10. #130
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,521
    Rep Power
    10
    In support of this Post:
    http://www.excelfox.com/forum/showth...ll=1#post11847


    Before
    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    A
    B
    C
    D
    1
    Voucher Date Link
    2
    Worksheet: Summary





    After for first two vouchers
    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    A
    B
    C
    D
    1
    Voucher Date Link
    2
    V0001 01.01.2020 Go To Sheet
    3
    V0002 01.01.2020 Go To Sheet
    4
    Worksheet: Summary





    After for all vouchers
    Remove this code line
    Code:
     ReDim arrUnicDtsSrc(0 To 0): Let arrUnicDtsSrc(0) = "01.01.2020_99909900 - A" ' ***** I am limiting it to the first unique identifier, ( 01.01.2020_99909900 - A ) just for demo purposes. If you remove this line,  then you will see that all dates and sources  will be considered
    _____ Workbook: BeforeDumpTemplate.xlsm ( Using Excel 2007 32 bit )
    Row\Col
    A
    B
    C
    D
    1
    Voucher Date Link
    2
    V0001 01.01.2020 Go To Sheet
    3
    V0002 01.01.2020 Go To Sheet
    4
    V0003 01.01.2020 Go To Sheet
    5
    V0004 01.01.2020 Go To Sheet
    6
    V0005 01.01.2020 Go To Sheet
    7
    V0006 02.01.2020 Go To Sheet
    8
    V0007 03.01.2020 Go To Sheet
    9
    V0008 04.01.2020 Go To Sheet
    10
    V0009 05.01.2020 Go To Sheet
    11
    V0010 06.01.2020 Go To Sheet
    12
    V0011 07.01.2020 Go To Sheet
    13
    V0012 08.01.2020 Go To Sheet
    14
    V0013 09.01.2020 Go To Sheet
    15
    V0014 10.01.2020 Go To Sheet
    16
    V0015 11.01.2020 Go To Sheet
    17
    V0016 12.01.2020 Go To Sheet
    18
    V0017 13.01.2020 Go To Sheet
    19
    V0018 14.01.2020 Go To Sheet
    20
    V0019 15.01.2020 Go To Sheet
    21
    Worksheet: Summary

Similar Threads

  1. Replies: 189
    Last Post: 02-06-2025, 02:53 PM
  2. Tests and Notes for EMail Threads
    By DocAElstein in forum Test Area
    Replies: 29
    Last Post: 11-15-2022, 04:39 PM
  3. Replies: 379
    Last Post: 11-13-2020, 07:44 PM
  4. Appendix Thread. Diet Protokol Coding Adaptions
    By DocAElstein in forum Test Area
    Replies: 6
    Last Post: 09-05-2019, 10:45 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
  •