-
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
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgyG714V_k7odQMrTz14AaABAg. 9h740K6COOA9iHOYYpaAbC
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgxuL6YCUckeUIh9hoh4AaABAg
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg. 9h4sd6Vs4qE9h7G-bVm8_-
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg. 9h6VhNCM-DZ9h7EqbG23kg
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwGTEyefOX7msIh1wZ4AaABAg. 9h4sd6Vs4qE9h7KvJXmK8o
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=Ugw3nF0C04AGt73H1BB4AaABAg. 9h6VhNCM-DZ9h7E1gwg4Aq
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgywFtBEpkHDuK55r214AaABAg
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg. 9h5lFRmix1R9h79hNGvJbu
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg. 9h5lFRmix1R9h79YAfa24T
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg. 9h5lFRmix1R9h79M1SYH1E
https://www.youtube.com/watch?v=2oT4qrHmDMY&lc=UgwviLabd7r_3KpP6wh4AaABAg. 9h5lFRmix1R9h78SxhXTnR
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
-
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 |
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 |
|
|
|
|
-
Coding for these Threads
https://stackoverflow.com/questions/...ication-ontime
http://www.excelfox.com/forum/showth...ll=1#post11870
https://stackoverflow.com/questions/...12342#59812342
Open workbook - MainFile.xls : https://app.box.com/s/prqhroiqcb0qccewz5si0h5kslsw5i5h
Module “Modul1” in MainFile.xls
(This is the main module from which all macros are run)
Code:
Option Explicit
' Public variable code section
Private Pbic_Arg1 As String
Public Pbic_Arg2 As Double
Dim sTemp As String
' _
_
Sub MainMacro() ' https://stackoverflow.com/questions/31439866/multiple-variable-arguments-to-application-ontime/31464597 http://markrowlinson.co.uk/articles.php?id=10
Rem 1
Debug.Print "Rem 1" & vbCr & vbLf & "This workbook module, single arrgument"
' This workbook module, single argument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderMainMacro 465'": Debug.Print "!'Modul1.UnderMainMacro 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderMainMacro ""465""'": Debug.Print "!'Modul1.UnderMainMacro ""465""'"
Application.OnTime Now(), "'Modul1.UnderMainMacro 465'" ' --- more usual simplified form. In this case I nned the extra Modul1. because Sub UnderMainMacro( ) is private
Debug.Print vbCr & vbLf & "UverFile module, single argument"
' UverFile module, single argument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroInUverFile 465'": Debug.Print "!'Modul1.MacroInUverFile 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroInUverFile ""465""'": Debug.Print "!'Modul1.MacroInUverFile ""465""'"
Debug.Print vbCr & vbLf & "Thisworkbook module, multiple arguments"
' Thisworkbook module, multiple arguments
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderUnderMainMacro 465, 25'": Debug.Print "!'Modul1.UnderUnderMainMacro 465, 25'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderUnderMainMacro 465, ""25""'": Debug.Print "!'Modul1.UnderUnderMainMacro 465, ""25""' "
Application.OnTime Now(), "'UnderUnderMainMacro 465, 25 '" ' --- more usual simplified form. I don't even need the extra Modul1. because it is not private
Debug.Print vbCr & vbLf & "UverFile module, multiple argument"
' UverFile module, multiple argument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroUnderMacroInUverFile 465, 25'": Debug.Print "!'Modul1.MacroUnderMacroInUverFile 465, 25'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'Modul1.MacroUndermacroInUverFile 465, ""25""'": Debug.Print "!'Modul1.MacroUndermacroInUverFile 465, ""25""'"
Debug.Print vbCr & vbLf & "mess about with argument positions"
' mess about with argument positions
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.UnderUnderMainMacro 465 , ""25"" '": Debug.Print "!'Modul1.UnderUnderMainMacro 465 , ""25"" '"
Debug.Print vbCr & vbLf & "This workbook first worksheet code module, single arrgument"
' This workbook first worksheet code module, single arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModule 465'": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModule 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModule ""465""'": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModule ""465""'"
Debug.Print vbCr & vbLf & "UverFile first worksheet code module, single arrgument"
' UverFile first worksheet code module, single arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule 465'": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule 465'"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule ""465""'": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModule ""465""'"
Debug.Print vbCr & vbLf & "This workbook first worksheet code module, multiple arguments"
' This workbook first worksheet code module, multiple arguments
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModuleMultipleArguments 465 , ""25"" '": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModuleMultipleArguments 465 , ""25"" '"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWsCodeModuleMultipleArguments ""465"" , 25 '": Debug.Print "!'" & ThisWorkbook.Worksheets.Item(1).CodeName & ".InLisWbFirstWcCodeModuleMultipleArguments ""465"" , 25 '"
Debug.Print vbCr & vbLf & "UverFile first worksheet code module, Multiple arrgument"
' UverFile first worksheet code module, Multiple arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments 465 , ""25"" '": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments 465 , ""25"" '"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & "UverFile.xls" & "'" & "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments ""465"" , ""25"" '": Debug.Print "!'" & "Tabelle1" & ".InUverFileFirstWsCodeModuleMultipleArguments ""465"" , ""25"" '"
Debug.Print vbCr & vbLf & "Doubles do not have to be in quotes either ' This workbook module, double argument arrgument"
' Doubles do not have to be in quotes either ' This workbook module, double argument arrgument
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck 465.5 , ""25.4"" '": Debug.Print "!'Modul1.DoubleCheck 465.5 , ""25.4"" '"
Rem 2 Variables
Debug.Print vbCr & vbLf & "Rem 2 Variables" & vbCr & vbLf & "'2a) ""Pseudo"" variables use"
'2a) "Pseudo" variables use
Dim Arg1_str465 As String, Arg2_Dbl25 As Double
Let Arg1_str465 = "465.42": Let Arg2_Dbl25 = 25.4
' Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck Arg1_str465 , Arg2_Dbl25 '": Debug.Print "!'Modul1.DoubleCheck Arg1_str465 , Arg2Db_l25 '" ' This code line will not work, that is to say it will not find the varables and take 0 values when VBA later runs the Scheduled macro, Sub DoubleCheck( )
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , """ & Arg2_Dbl25 & """ '": Debug.Print "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , """ & Arg2_Dbl25 & """ '"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , " & Arg2_Dbl25 & " '": Debug.Print "!'Modul1.DoubleCheck """ & Arg1_str465 & """ , " & Arg2_Dbl25 & " '"
Debug.Print vbCr & vbLf & "'2b) Real varable use"
'2b) Real varable use
Let Modul1.Pbic_Arg1 = "465.42": Let Pbic_Arg2 = 25.4
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck Modul1.Pbic_Arg1 , Pbic_Arg2 '": Debug.Print "!'Modul1.DoubleCheck Modul1.Pbic_Arg1 , Pbic_Arg2 '"
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.DoubleCheck Modul1.Pbic_Arg1, Pbic_Arg2'"
'' Debug.Print Pbic_Arg2 '' This gives 999.99 in Debug F8 mode , 25.4 in normal run
Rem 3 ByRef check
Application.OnTime Now(), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.ByRefCheck'"
Application.OnTime Now() + TimeValue("00:00:00"), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.ByRefCheck'"
Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & "'" & "!'Modul1.ByRefCheck'"
End Sub
Private Sub UnderMainMacro(ByVal Nmbr As Long)
MsgBox prompt:="Arg1 is " & Nmbr
End Sub
Sub UnderUnderMainMacro(ByVal Nmbr As Long, ByVal NuverNmbr As Long)
MsgBox prompt:="Arg1 is " & Nmbr & ", Arg2 is " & NuverNmbr
End Sub
Sub DoubleCheck(ByVal DblNmr1 As Double, ByRef DblNmr2 As Double) ' provided the signature line is declared appropriately, all number argument types dont have to be in ""
MsgBox prompt:="Arg1 is " & DblNmr1 & ", Arg2 is " & DblNmr2
Let DblNmr2 = 999.99
End Sub
Sub ByRefCheck()
Debug.Print vbCr & vbLf & vbCr & vbLf & vbCr & vbLf & "Rem 3 ByRef Check" & vbCr & vbLf & Pbic_Arg2
End Sub
-
Coding in support of this Thread
Code:
Option Explicit
' Module scope variable code section
Public Eye As Long
Private Jay As Long
Dim KEh As Long
' Main scheduling macro 1
Sub ByVal_GEhtitsAppObj_1()
1 Application.OnTime Now(), "'CalledByVal Eye, Jay, KEh'"
Let Eye = 11: Let Jay = 12: Let KEh = 13
Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'"
End Sub
' Main scheduling macro 2
Sub ByVal_GEhtitsAppObj_2()
2 Application.OnTime Now(), "'CalledByVal Module1.Eye, Module1.Jay, Module1.KEh'" '_--- Fix _ 2) Module1.MyVariable
Let Eye = 21: Let Jay = 22: Let KEh = 23
Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'"
End Sub
' Main scheduling macro 3
Sub ByRef_GEhtitsAppObj_3()
3 Application.OnTime Now(), "'CalledByRef Eye, Jay, KEh'"
Let Eye = 31: Let Jay = 32: Let KEh = 33
Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'"
End Sub
' Main scheduling macro 4
Sub ByRef_GEhtitsAppObj_4()
4 Application.OnTime Now(), "'CalledByRef Module1.Eye, Module1.Jay, Module1.KEh'" '_--- Fix _ 2) Module1.MyVariable
Let Eye = 41: Let Jay = 42: Let KEh = 43
' Application.OnTime Now(), "'WtchaGotModScopeVariables'" ' ByRef is not working if this is done
Application.OnTime Now() + TimeValue("00:00:01"), "'WtchaGotModScopeVariables'" '_--- Fix _ 1) to get ByRef to work
End Sub
Sub WtchaGotModScopeVariables()
Debug.Print Eye & " " & Jay & " " & KEh & vbCr & vbLf
End Sub
Sub CalledByVal(ByVal I As Long, ByVal J As Long, ByVal K As Long)
Debug.Print I & " " & J & " " & K
Let I = I + 1000: Let J = J + 1000: Let K = K + 1000
End Sub
Sub CalledByRef(ByRef I As Long, ByRef J As Long, ByRef K As Long)
Debug.Print I & " " & J & " " & K
Let I = I + 2000: Let J = J + 2000: Let K = K + 2000
End Sub
'Results
' Macro 1
' 11 0 0
' 11 12 13
'
' Macro 2
' 21 22 23
' 21 22 23
'
' Macro 3
'
' Fail!!!!!
'
'
' Macro 4
' 41 42 43
' 2041 2042 2043
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
'
Sub GEhtitsAppObject()
1
2 Rem 1 Simple use of variables
Let Eye = 31: Let Jay = 32: Let KEh = 33
3 Debug.Print Eye & " " & Jay & " " & KEh
Let Eye = 41: Let Jay = 42: Let KEh = 43
4 Debug.Print Module1.Eye & " " & Module1.Jay & " " & Module1.KEh
5
6 Rem 2 Call ing Subs with variable arguments
Let Eye = 71: Let Jay = 72: Let KEh = 73
7 Call CalledByVal(Eye, Jay, KEh)
Let Eye = 81: Let Jay = 82: Let KEh = 83
8 Call CalledByVal(Module1.Eye, Module1.Jay, Module1.KEh)
9
Let Eye = 101: Let Jay = 102: Let KEh = 103
10 Call CalledByRef(Eye, Jay, KEh)
Let Eye = 111: Let Jay = 112: Let KEh = 113
11 Call CalledByRef(Module1.Eye, Module1.Jay, Module1.KEh)
12
13 Rem 3 Application.OnTime
Let Eye = 141: Let Jay = 142: Let KEh = 143
14 Application.OnTime Now(), "'CalledByVal Module1.Eye, Module1.Jay, Module1.KEh'"
Let Eye = 151: Let Jay = 152: Let KEh = 153
15 Application.OnTime Now(), "'CalledByVal Eye, Jay, KEh'"
16
Let Eye = 171: Let Jay = 172: Let KEh = 173
17 'Application.OnTime Now(), "'CalledByRef Eye, Jay, KEh'"
Let Eye = 181: Let Jay = 182: Let KEh = 183
18 Application.OnTime Now(), "'CalledByRef Module1.Eye, Module1.Jay, Module1.KEh'"
19
End Sub
'20 Rem 4 Application.Run
' Let Eye = 211: Let Jay = 212: Let KEh = 213
'21 Application.Run "CalledByVal", Eye, Jay, KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'
' Let Eye = 221: Let Jay = 222: Let KEh = 223
'22 Application.Run "CalledByVal", Module1.Eye, Module1.Jay, Module1.KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'23
'
' Let Eye = 241: Let Jay = 242: Let KEh = 243
'24 Application.Run "CalledByRef", Module1.Eye, Module1.Jay, Module1.KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'
' Let Eye = 251: Let Jay = 252: Let KEh = 253
'25 Application.Run "CalledByRef", Eye, Jay, KEh
' Debug.Print Eye & " " & Jay & " " & KEh
'
'End Sub
' Sub CalledByVal(ByVal I As Long, ByVal J As Long, ByVal K As Long)
' Debug.Print I & " " & J & " " & K
' Let I = I + 1000: Let J = J + 1000: Let K = K + 1000
' End Sub
' Sub CalledByRef(ByRef I As Long, ByRef J As Long, ByRef K As Long)
' Debug.Print I & " " & J & " " & K
' Let I = I + 2000: Let J = J + 2000: Let K = K + 2000
' End Sub
