-
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
-
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
'
-
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
-
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
'
-
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 |
|
|
|
|
-
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 |
-
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 |
|
-
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 |
_____ 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 |
-
2 Attachment(s)
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
-
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 |
|
|
|
|
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 |
|
|
|
|
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 |
|
|
|
|
