Related
Is it possible to split a string every fourth delimiter?
We receive a text file that has one string containing several days data.
I would like to split once using the '|' as the delimiter, but different days data is joined by a comma.
Option Explicit
Sub Split4thdelim()
Dim strOriginal as string
Dim originalArry() as string
Dim X as long
strOriginal = "01/01/2020|user1,89|user2,90|user3,99,02/01/2020|user1,80|user2,85|user3,97,03/01/2020|user1,88|user2,96|user3,99"
originalArry = split(strOriginal,"|")
For X = originalArry(originalArry(Lbound)) to originalArry(originalArry(Ubound))
Debug.Print originalArry(X)
Next
End Sub
I would like to split it like this:
01/01/2020
user1,89
user2,90
user3,99
02/01/2020
user1,80
user2,85
user3,97
03/01/2020
user1,88
user2,96
user3,99
Sub Split4thdelim()
Dim strOriginal As String
Dim originalArry() As String
Dim X As Long, n As Long
strOriginal = "01/01/2020|user1,89|user2,90|user3,99,02/01/2020|user1," & _
"80|user2,85|user3,97,03/01/2020|user1,88|user2,96|user3,99"
'replace every fourth "," with chr(0)
For X = 1 To Len(strOriginal)
If Mid(strOriginal, X, 1) = "," Then
n = n + 1
If n Mod 4 = 0 Then Mid(strOriginal, X, 1) = Chr(0)
End If
Next X
originalArry = Split(strOriginal, Chr(0))
For X = LBound(originalArry) To UBound(originalArry)
Debug.Print Join(Split(originalArry(X), "|"), vbLf)
Next
End Sub
Do it manually:
Sub Split4thdelim()
Dim strOriginal As String
Dim Token As New Collection
Dim strToken As String
Dim X As Long
strOriginal = "01/01/2020|user1,89|user2,90|user3,99,02/01/2020|user1,80|user2,85|user3,97,03/01/2020|user1,88|user2,96|user3,99"
Dim Pos As Long
Dim strTemp As String
Pos = InStr(1, strOriginal, "user")
Token.Add Mid(strOriginal, 1, Pos - 2)
strOriginal = Right(strOriginal, Len(strOriginal) - Pos + 1)
While Pos > 0
Pos = InStr(2, strOriginal, "user")
Token.Add Mid(strOriginal, 1, Pos - 2)
strOriginal = Right(strOriginal, Len(strOriginal) - Pos + 1)
Pos = InStr(2, strOriginal, "user")
Token.Add Mid(strOriginal, 1, Pos - 2)
strOriginal = Right(strOriginal, Len(strOriginal) - Pos + 1)
Pos = InStr(2, strOriginal, "user")
If Pos = 0 Then 'no more user, so this is the last set
Token.Add Right(strOriginal, Len(strOriginal) - Pos)
Else
strTemp = Left(strOriginal, Pos - 2)
strOriginal = Right(strOriginal, Len(strOriginal) - Pos + 1) 'save new strOriginal
Pos = InStr(1, strOriginal, ",")
strToken = Mid(strTemp, 1, Pos)
strTemp = Right(strTemp, Len(strTemp) - Pos)
Pos = InStr(1, strTemp, ",")
If Pos = 0 Then
Pos = InStr(1, strTemp, "|")
End If
strToken = strToken + Mid(strTemp, 1, Pos - 1)
Token.Add strToken
Token.Add Right(strTemp, Len(strTemp) - Pos)
End If
Wend
Dim strItem As Variant
For Each strItem In Token
Debug.Print strItem
Next strItem
End Sub
Try,
Sub Split4thdelim()
Dim strOriginal As String
Dim originalArry() As String
Dim X As Long
Dim vSplit, s As String, s2 As String
Dim vR()
Dim n As Long
strOriginal = "01/01/2020|user1,89|user2,90|user3,99,02/01/2020|user1,80|user2,85|user3,97,03/01/2020|user1,88|user2,96|user3,99"
originalArry = Split(strOriginal, "|")
For X = LBound(originalArry) To UBound(originalArry)
'Debug.Print originalArry(X)
s = originalArry(X)
If InStr(s, "/") And InStr(s, ",") Then
n = n + 2
vSplit = Split(s, ",")
s2 = vSplit(UBound(vSplit))
ReDim Preserve vR(1 To n)
vR(n - 1) = Replace(s, "," & s2, "")
vR(n) = s2
Else
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = s
End If
Next
Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End Sub
or ...
Option Explicit
Sub Split4thdelim()
Dim strOriginal As String
Dim vCounter As Long
Dim vNewElement As String
Dim vCommaCount As Long
strOriginal = "01/01/2020|user1,89|user2,90|user3,99,02/01/2020|user1,80|user2,85|user3,97,03/01/2020|user1,88|user2,96|user3,99"
vNewElement = ""
vCommaCount = 0
For vCounter = 1 To Len(strOriginal)
If Mid$(strOriginal, vCounter, 1) <> "|" And Mid$(strOriginal, vCounter, 1) <> "," Then
vNewElement = vNewElement & Mid$(strOriginal, vCounter, 1)
Else
If Mid$(strOriginal, vCounter, 1) = "|" Then
Debug.Print vNewElement
vNewElement = ""
vCommaCount = 0
ElseIf Mid$(strOriginal, vCounter, 1) = "," Then
vCommaCount = vCommaCount + 1
If vCommaCount = 2 Then
Debug.Print vNewElement
vNewElement = ""
vCommaCount = 0
Else
vNewElement = vNewElement & Mid$(strOriginal, vCounter, 1)
End If
End If
End If
Next
Debug.Print vNewElement
End Sub
I have code that parses out the last word on a string.
ie. Stack/Over/Flow will give me "Flow".
But I want to get "Over/Flow".
This is what I got, but only able to get "Flow"
arr(counter - 2) = "'" & mid(Text, InStrRev(Text, "/") + 1) & "'"
I would use Split()
Sub lastTwo()
Dim str As String
str = "Stack/Over/Flow"
Dim splt() As String
splt = Split(str, "/")
If UBound(splt) > 0 Then
Debug.Print splt(UBound(splt) - 1) & "/" & splt(UBound(splt))
End If
End Sub
Here is a function that does it:
Function lastParts(str As String, delim As String, x As Long) As String
Dim splt() As String
splt = Split(str, "/")
If UBound(splt) + 1 >= x Then
Dim t As String
t = "=INDEX(INDEX({""" & Join(splt, """;""") & """},N(IF({1},ROW(" & UBound(splt) - x + 2 & ":" & UBound(splt) + 1 & "))),),)"
lastParts = Join(Application.Transpose(Application.Evaluate(t)), delim)
Else
lastParts = str
End If
End Function
It has three parts, the string, the delimiter and the number of returns.
It can be called using your code:
arr(counter-2) = lastParts(Text,"/",2)
or from the worksheet
=lastParts(A1,"/",2)
Initially misread the question. You can nest InStrRev() calls
arr(counter - 2) = "'" & mid(Text, InStrRev(Text, "/",InStrRev(Text, "/")-1)+1) & "'"
In VBA, how do you convert text containing Unicode to HTML entities?
Eg. Test chars: èéâ👍 would be converted to Test chars: èéâ👍
In Excel, characters are stored using Unicode UTF-16. The "Thumbs up" character (👍) corresponds to the Unicode character U+1F44D, encoded as follows:
in UTF-16 (hex) : 0xD83D 0xDC4D (d83ddc4d)
in UTF-16 (decimal) : 55357 , 56397
The following function (and test procedure) should convert as expected:
Sub test()
txt = String2Html("Test chars: èéâ" & ChrW(&HD83D) & ChrW(&HDC4D))
debug.print txt ' -> Test chars: èéâ👍
End Sub
Function String2Html(strText As String) As String
Dim i As Integer
Dim strOut As String
Dim char As String
Dim char2 As String
Dim intCharCode As Integer
Dim intChar2Code As Integer
Dim unicode_cp As Long
For i = 1 To Len(strText)
char = Mid(strText, i, 1)
intCharCode = AscW(char)
If (intCharCode And &HD800) = &HD800 Then
i = i + 1
char2 = Mid(strText, i, 1)
intChar2Code = AscW(char2)
unicode_cp = (intCharCode And &H3FF) * (2 ^ 10) + (intChar2Code And &H3FF)
strOut = strOut & "&#x" & CStr((intCharCode And &H3C0) + 1) & Hex(unicode_cp) & ";"
ElseIf intCharCode > 127 Then
strOut = strOut & "&#x" & Hex(intCharCode) & ";"
ElseIf intCharCode < 0 Then
strOut = strOut & "&#x" & Hex(65536 + intCharCode) & ";"
Else
strOut = strOut & char
End If
Next
String2Html = strOut
End Function
To convert Unicode to Asci (eg: æ to æ)
Public Function UnicodeToAscii(sText As String) As String
Dim x As Long, sAscii As String, ascval As Long
If Len(sText) = 0 Then
Exit Function
End If
sAscii = ""
For x = 1 To Len(sText)
ascval = AscW(Mid(sText, x, 1))
If (ascval < 0) Then
ascval = 65536 + ascval ' http://support.microsoft.com/kb/272138
End If
sAscii = sAscii & "&#" & ascval & ";"
Next
UnicodeToAscii = sAscii
End Function
To convert Asci to Unicode (eg: æ to æ)
Public Function AsciiToUnicode(sText As String) As String
Dim saText() As String, sChar As String
Dim sFinal As String, saFinal() As String
Dim x As Long, lPos As Long
If Len(sText) = 0 Then
Exit Function
End If
saText = Split(sText, ";") 'Unicode Chars are semicolon separated
If UBound(saText) = 0 And InStr(1, sText, "&#") = 0 Then
AsciiToUnicode = sText
Exit Function
End If
ReDim saFinal(UBound(saText))
For x = 0 To UBound(saText)
lPos = InStr(1, saText(x), "&#", vbTextCompare)
If lPos > 0 Then
sChar = Mid$(saText(x), lPos + 2, Len(saText(x)) - (lPos + 1))
If IsNumeric(sChar) Then
If CLng(sChar) > 255 Then
sChar = ChrW$(sChar)
Else
sChar = Chr$(sChar)
End If
End If
saFinal(x) = Left$(saText(x), lPos - 1) & sChar
ElseIf x < UBound(saText) Then
saFinal(x) = saText(x) & ";" 'This Semicolon wasn't a Unicode Character
Else
saFinal(x) = saText(x)
End If
Next
sFinal = Join(saFinal, "")
AsciiToUnicode = sFinal
Erase saText
Erase saFinal
End Function
I hope this would be help someone,
I got this code from here
After all my searching for code to read in a VLOOKUP formula and converting it to INDEX/MATCH came up empty, I wrote some myself.
However, the code (below) is lacking some of the flexibility I would like, but I can't seem to figure out how to make it work. Specifically, I would like to test each range criterion in the VLOOKUP formula for being an absolute reference or not, i.e. preceded by $, and carry that through to the INDEX/MATCH formula that results. For example, the formula =VLOOKUP(A2,$A$1:B$11,2,FALSE) should convert to =INDEX(B$1:B$11,MATCH(A2,$A1:$A11,0)).
NOTE: This sub depends on two functions (ColumnLetterToNumber and ColumnNumberToLetter). As their names imply they take column letters or numbers and interconvert them. Both these functions are short, simple, and work without problems. However, if anyone believes that the code to one or both of them would be helpful, I would be happy to provide them.
Additionally, any ideas on improving code readability and/or execution efficiency would also be appreciated.
Option Explicit
Public Sub ConvertToIndex()
Dim booLookupType As Boolean
Dim booLeftOfColon As Boolean
Dim booHasRowRef As Boolean
Dim lngStartCol As Long
Dim lngRefCol As Long
Dim lngStart As Long
Dim lngEnd As Long
Dim lngMatchType As Long
Dim lngInt As Long
Dim lngRowRef As Long
Dim strRefCol As String
Dim strOldFormula As String
Dim strNewFormula As String
Dim strLookupCell As String
Dim strValueCol As String
Dim strMatchCol As String
Dim strStartRow As String
Dim strEndRow As String
Dim strCheck As String
Dim strLookupRange As String
Dim strTabRef As String
Dim strSheetRef As String
Dim rngToMod As Range
Dim rngModCell As Range
Set rngToMod = Selection
For Each rngModCell In rngToMod
strOldFormula = rngModCell.Formula
lngStart = InStrRev(strOldFormula, "VLOOKUP(")
If lngStart > 0 Then
lngStart = InStr(lngStart, strOldFormula, "(") + 1
lngEnd = InStr(lngStart, strOldFormula, ",")
strLookupCell = Mid(strOldFormula, lngStart, lngEnd - lngStart)
lngStart = lngEnd + 1
lngEnd = InStr(lngStart, strOldFormula, ",")
strLookupRange = Mid(strOldFormula, lngStart, lngEnd - lngStart)
lngStart = lngEnd + 1
lngEnd = InStr(lngStart, strOldFormula, ",")
lngRefCol = CInt(Mid(strOldFormula, lngStart, lngEnd - lngStart))
lngStart = lngEnd + 1
lngEnd = InStr(lngStart, strOldFormula, ")")
booLookupType = (Mid(strOldFormula, lngStart, lngEnd - lngStart) = "TRUE")
If booLookupType Then
lngMatchType = 1
Else
lngMatchType = 0
End If
booLeftOfColon = True
lngEnd = InStr(1, strLookupRange, "]")
If lngEnd > 0 Then
strSheetRef = Left(strLookupRange, lngEnd)
strLookupRange = Right(strLookupRange, Len(strLookupRange) - lngEnd)
Else
strSheetRef = ""
End If
lngEnd = InStr(1, strLookupRange, "!")
If lngEnd > 0 Then
strTabRef = Left(strLookupRange, lngEnd)
strLookupRange = Right(strLookupRange, Len(strLookupRange) - lngEnd)
Else
strTabRef = ""
End If
For lngInt = 1 To Len(strLookupRange)
strCheck = Mid(strLookupRange, lngInt, 1)
Select Case True
Case strCheck = ":"
booLeftOfColon = False
Case booLeftOfColon
If IsNumeric(strCheck) Then
strStartRow = strStartRow & strCheck
Else
strMatchCol = strMatchCol & strCheck
End If
Case Else
If IsNumeric(strCheck) Then strEndRow = strEndRow & strCheck
End Select
Next lngInt
strMatchCol = Replace(strMatchCol, "$", "")
lngStartCol = ColumnLetterToNumber(strMatchCol)
strValueCol = ColumnNumberToLetter(lngStartCol + lngRefCol - 1)
If Len(strStartRow) > 0 Then strStartRow = "$" & strStartRow
If Len(strEndRow) > 0 Then strEndRow = "$" & strEndRow
strValueCol = strSheetRef & strTabRef & strValueCol & strStartRow & ":" & strValueCol & strEndRow
strMatchCol = strSheetRef & strTabRef & strMatchCol & strStartRow & ":" & strMatchCol & strEndRow
strNewFormula = "=INDEX(" & strValueCol & ",MATCH(" & "$" & strLookupCell & "," & strMatchCol & "," & lngMatchType & "))"
rngModCell.Formula = strNewFormula
End If
Next rngModCell
End Sub
At this time I am not looking for help to take this to the next step of enabling it to process VLOOKUP/HLOOKUP or VLOOKUP/MATCH combination formulas.
To avoid all errors I can think of, you would need to change it to a not so good looking way like this:
Sub changeToIndex()
Dim xText As Boolean
Dim xBrac As Long
Dim VLSep As New Collection
Dim i As Long, t As String
With Selection.Cells(1, 1) 'just for now
'it assumes that there is NEVER a text string which has VLOOKUP like =A1&"mean text with VLOOKUP inside it"
While InStr(1, .Formula, "VLOOKUP", vbTextCompare)
Set VLSep = New Collection
VLSep.Add " " & InStr(1, .Formula, "VLOOKUP", vbTextCompare) + 7
'get the parts
For i = VLSep(1) + 1 To Len(.Formula)
t = Mid(.Formula, i, 1)
If t = """" Then
xText = Not xText
ElseIf Not xText Then 'avoid "(", ")" and "," inside of the string to be count
If t = "(" Then
xBrac = xBrac + 1
ElseIf xBrac Then 'cover up if inside of other functions
If t = ")" Then xBrac = xBrac - 1
ElseIf t = ")" Then
VLSep.Add " " & i
Exit For
ElseIf t = "," Then
VLSep.Add " " & i 'the space is to avoid errors with index and item if both are numbers
End If
End If
Next
Dim xFind As String 'get all the parts
Dim xRng As String
Dim xCol As String
Dim xType As String
xFind = Mid(.Formula, VLSep(1) + 1, VLSep(2) - VLSep(1) - 1)
xRng = Mid(.Formula, VLSep(2) + 1, VLSep(3) - VLSep(2) - 1)
xCol = Mid(.Formula, VLSep(3) + 1, VLSep(4) - VLSep(3) - 1)
If VLSep.Count = 5 Then
xType = Mid(.Formula, VLSep(4) + 1, VLSep(5) - VLSep(4) - 1)
Else
xType = "0"
End If
Dim fullFormulaNew As String 'get the whole formulas
Dim fullFormulaOld As String
fullFormulaNew = "INDEX(" & xRng & ",MATCH(" & xFind & ",INDEX(" & xRng & ",,1)," & xType & ")," & xCol & ")"
fullFormulaOld = Mid(Selection.Cells(1, 1).Formula, VLSep(1) - 7, VLSep(VLSep.Count) - VLSep(1) + 8)
.Formula = Replace(.Formula, fullFormulaOld, fullFormulaNew) 'simply replace the old one with the new one
Wend
End With
End Sub
It also should work for very complex formulas. Still you would need some special checks to cut everything so it looks like you want. I just assumed that the range for the vlookup may be something like IF(A1=1,B1:C10,L5:N30) and this said, you would need additional subs to also clear something like this up. :(
A formula like
=VLOOKUP(VLOOKUP(IF(TRUE,A2,"aaa"),$A$1:B$11,2),$B$1:$C$11,2,FALSE)
will be changed (messed up) this way to
=INDEX($B$1:$C$11,MATCH(INDEX($A$1:B$11,MATCH(IF(TRUE,A2,"aaa"),INDEX($A$1:B$11,,1),0),2),INDEX($B$1:$C$11,,1),FALSE),2)
EDIT
Assuming your formulas are "normal" you can replace the the last part with:
Dim xFind As String 'get all the parts
Dim xRngI As String, xRngM As String
Dim xCol As String
Dim xType As String
xFind = Mid(.Formula, VLSep(1) + 1, VLSep(2) - VLSep(1) - 1)
xRngI = Mid(.Formula, VLSep(2) + 1, VLSep(3) - VLSep(2) - 1)
xCol = Mid(.Formula, VLSep(3) + 1, VLSep(4) - VLSep(3) - 1)
If VLSep.Count = 5 Then
xType = Mid(.Formula, VLSep(4) + 1, VLSep(5) - VLSep(4) - 1)
Else
xType = "0"
End If
If xType = "FALSE" Then xType = 0
Do While Not IsNumeric(xCol)
Select Case MsgBox("Error: The Column to pick from is not numerical! Do you want to manually set the column (Yes) or directly use the last column of the input range (No)?", vbYesNoCancel)
Case vbYes
xCol = Application.InputBox("Input the column number for the input range (" & xRngI & "). '1' will be the range " & Range(xRngI).Columns(1).Address(0, 0) & ".", "Column to pick from", 1, , , , , 2)
Case vbNo
xCol = Range(xRngI).Columns.Count
Case vbCancel
xCol = " "
Exit Do
End Select
If xCol <> CInt(xCol) Or xCol > Range(xRngI).Columns.Count Or xCol = 0 Then xCol = " "
Loop
If IsNumeric(xCol) Then
Dim absRs As Boolean, absRe As Boolean, absCs As Boolean, absCe As Boolean
absCs = (Left(xRngI, 1) = "$")
absCe = (Mid(xRngI, InStr(xRngI, ":") + 1, 1) = "$")
absRs = (InStr(2, Left(xRngI, InStr(xRngI, ":") - 1), "$") > 0)
absRe = (InStr(Mid(xRngI, InStr(xRngI, ":") + 2), "$") > 0)
xRngM = Range(xRngI).Columns(1).Cells(1, 1).Address(absRs, absCs) & ":" & Range(xRngI).Columns(1).Cells(Range(xRngI).Rows.Count, 1).Address(absRe, absCs) 'for MATCH
xRngI = Range(xRngI).Cells(1, CLng(xCol)).Address(absRs, absCe) & ":" & Range(xRngI).Cells(Range(xRngI).Rows.Count, CLng(xCol)).Address(absRe, absCe) 'for INDEX
Dim fullFormulaNew As String, fullFormulaOld As String
fullFormulaNew = "INDEX(" & xRngI & ",MATCH(" & xFind & "," & xRngM & "," & xType & "))"
fullFormulaOld = Mid(Selection.Cells(1, 1).Formula, VLSep(1) - 7, VLSep(VLSep.Count) - VLSep(1) + 8)
.Formula = Replace(.Formula, fullFormulaOld, fullFormulaNew) 'simply replace the old one with the new one
End If
Wend
End With
End Sub
As you can see: the "simpler" the outcome, the more code you need. If the lookup_range is not just a address, this will fail.
If you still have any questions, just ask ;)
I want to have line numbers in my VBA code for debugging reasons. That will allow me to know where a particular error occurred.
Is there an automatic feature for this (such as an option in settings)? Or do I need to write my own macro?
If I need to write my own macro to accomplish this task, how would I go about doing such a thing?
You don't want line numbers.
Not for "debugging reasons", not for anything. Line numbers are deprecated for a reason: they're a relic of an ancient time before procedures even existed, and GOTO the only way to get anywhere.
Erl only returns the last encountered line number before an error was raised. This can mean misleading error logs, if you're logging errors:
Sub DoSomething()
10 On Error GoTo 50
Debug.Print 42 / 0
30 Exit Sub
50 Debug.Print "Error raised on line " & Erl 'returns 10
End Sub
Also, line numbers only have Integer resolution (a VBA module can have up to 65,535 lines, which is twice that resolution), and will silently fail and happily report wrong line numbers if you don't keep that in mind:
Sub DoSomething()
99997 On Error GoTo 99999
99998 Debug.Print 42 / 0
99999
Debug.Print Erl 'Prints 34462 - and which line is that?
End Sub
Any serious VBA application will use structured error handling instead.
Write small, specialized procedures (i.e. write code that follows modern-day best practices), and the line number becomes utterly meaningless.
Line numbers are a pain in the neck to maintain; they clutter up the code and make it overall harder to read (and therefore to debug).
That said, IIRC MZ-Tools 3 had such a functionality.
Keep in mind, that BASIC looked like this when line numbers were a thing:
10 GOSUB 100
20 GOSUB 1000
99 END
100 REM CLEAR SCREEN
110 PRINT CHR$(147)
120 RETURN
200 REM MODULO
210 LET MOD% = V%-INT(V%/FB%)*FB%
220 RETURN
1000 REM INIT VARIABLES
1010 LET FIZZ$ = "FIZZ"
1011 LET BUZZ$ = "BUZZ"
1020 LET FIZZ% = 3
1021 LET BUZZ% = 5
1030 LET MIN% = 1
1031 LET MAX% = 15
1100 PRINT FIZZ$ + ":" + STR$(FIZZ%)
1101 PRINT BUZZ$ + ":" + STR(BUZZ%)
1102 PRINT FIZZ$ + BUZZ$ + ":" + STR$(FIZZ%*BUZZ%)
1105 PRINT
2000 REM ACTUAL FIZZBUZZ LOOP
2010 FOR X = MIN% TO MAX%
2015 LET RESULT$ = STR$(X)
2020 LET FB% = FIZZ%*BUZZ%
2021 LET V% = X
2024 GOSUB 200
2025 IF MOD%=0 THEN LET RESULT$=FIZZ$+BUZZ$ : GOTO 2050
2030 LET FB% = FIZZ%
2031 GOSUB 200
2035 IF MOD%=0 THEN LET RESULT$=FIZZ$ : GOTO 2050
2040 LET FB% = BUZZ%
2041 GOSUB 200
2045 IF MOD%=0 THEN LET RESULT$=BUZZ$ : GOTO 2050
2050 PRINT RESULT$
2090 NEXT X
2099 RETURN
The above is a working Commodore 64 BASIC 2.0 fizzbuzz program. VBA has fabulous backward-compatibility. With only slight modifications, it runs in VBA:
Sub Main()
10 GoSub 100
20 GoSub 1000
99 End
100 Rem CLEAR SCREEN
110 'Debug.Print Chr$(147) 'Chr$(147) was a special character on C64
120 Return
200 Rem MODULO
210 Let Modulo% = V% - Int(V% / FB%) * FB%
220 Return
1000 Rem INIT VARIABLES
1010 Let FIZZ$ = "FIZZ"
1011 Let BUZZ$ = "BUZZ"
1020 Let FZZ% = 3
1021 Let BZZ% = 5
1030 Let Min% = 1
1031 Let Max% = 15
1100 Debug.Print FIZZ$ + ":" + Str$(FZZ%)
1101 Debug.Print BUZZ$ + ":" + Str(BZZ%)
1102 Debug.Print FIZZ$ + BUZZ$ + ":" + Str$(FZZ% * BZZ%)
1105 Debug.Print
2000 Rem ACTUAL FIZZBUZZ LOOP
2010 For X = Min% To Max%
2015 Let RESULT$ = Str$(X)
2020 Let FB% = FZZ% * BZZ%
2021 Let V% = X
2024 GoSub 200
2025 If Modulo% = 0 Then Let RESULT$ = FIZZ$ + BUZZ$: GoTo 2050
2030 Let FB% = FZZ%
2031 GoSub 200
2035 If Modulo% = 0 Then Let RESULT$ = FIZZ$: GoTo 2050
2040 Let FB% = BZZ%
2041 GoSub 200
2045 If Modulo% = 0 Then Let RESULT$ = BUZZ$: GoTo 2050
2050 Debug.Print RESULT$
2090 Next X
2099 Return
End Sub
Don't write 1980's code, we're 40 years later.
I use this code for adding line numbers to my Excel projects. I found it online a while back and I don't remember where I got it, so credit goes to whoever originally wrote this:
Sub AddLineNumbers(wbName As String, vbCompName As String)
'See MakeUF
Dim i As Long, j As Long, lineN As Long
Dim procName As String
Dim startOfProceedure As Long
Dim lengthOfProceedure As Long
Dim newLine As String
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
.CodePane.Window.Visible = False
For i = 1 To .CountOfLines
procName = .ProcOfLine(i, vbext_pk_Proc)
If procName <> vbNullString Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Proc)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Proc)
If startOfProceedure + 1 < i And i < startOfProceedure + lengthOfProceedure - 1 Then
newLine = RemoveOneLineNumber(.Lines(i, 1))
If Not HasLabel(newLine) And Not (.Lines(i - 1, 1) Like "* _") Then
.ReplaceLine i, CStr(i) & ":" & newLine
End If
End If
End If
Next i
.CodePane.Window.Visible = True
End With
End Sub
Sub RemoveLineNumbers(wbName As String, vbCompName As String)
'See MakeUF
Dim i As Long
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
For i = 1 To .CountOfLines
.ReplaceLine i, RemoveOneLineNumber(.Lines(i, 1))
Next i
End With
End Sub
Function RemoveOneLineNumber(aString)
RemoveOneLineNumber = aString
If aString Like "#:*" Or aString Like "##:*" Or aString Like "###:*" Then
RemoveOneLineNumber = Mid(aString, 1 + InStr(1, aString, ":", vbTextCompare))
End If
End Function
Function HasLabel(ByVal aString As String) As Boolean
HasLabel = InStr(1, aString & ":", ":") < InStr(1, aString & " ", " ")
End Function
You'll have to modify it to suit your needs since you're working in Access, but I'm sure the main meat of it still applies. In Excel, there's a userform that is used to kick off the code for the module you specify, but you should be able to just pass in the module name (vbCompName) to specify the module. I'm not well-versed in Access VBA, so I'm not sure what you'd replace Workbooks(wbName) with in the code.
The VBA editor has a built in way to see a line number, under the 'Standard' toolbar:
When you select a line of code, the line number will be represented here next to 'Ln'.
MZ-Tools for VBA has functions to add and remove line numbers to single functions, modules, or the whole project.
See http://www.mztools.com/v8/onlinehelp/index.html?add_remove_line_numbers.htm
Note 1: I find it better to configure the line number increment to 1 instead of 10. You will never manually add line numbers inbetween - whenever you edit the code, you first remove the line numbers, then add them back when you are finished.
Note 2: Until a few years ago, there was a free version 3.0 of MZ-Tools, but it is surprisingly difficult to find a copy. But it is a good investment - there are lots of other useful features (e.g. the automatic adding of error handlers).
The answer of Arich works like a charm on an individual module. If you want to provide your entire workbook with (updated) line numbers you apply the following steps*^:
Do Once:
Paste the large code from Module2 in your workbook.
Paste the code for Module3 in your workbook.
Paste the code for Module4 in your workbook.
Then paste the line Global allow_for_line_addition As Stringthis is just so that you can automatically add linenumbers` above/in the first line of every
module.
Delete all empty lines at the end of each module (so no lose enters after the last end sub,end function or End Property of a module).
In the VBA editor, while not running a code, and not being in "break"-mode:click tools>references>mark: `Microsoft Visual Basic for Applications Extensibility 5.3"
Do every time you have modified your code:
°Run the code for Module3 to remove line numbers to all the modules in your workbook.
°Run the code for Module4 to add line numbers to all the modules in your workbook.
Module2:
Public Enum vbLineNumbers_LabelTypes
vbLabelColon ' 0
vbLabelTab ' 1
End Enum
Public Enum vbLineNumbers_ScopeToAddLineNumbersTo
vbScopeAllProc ' 1
vbScopeThisProc ' 2
End Enum
Sub AddLineNumbers(ByVal wbName As String, _
ByVal vbCompName As String, _
ByVal LabelType As vbLineNumbers_LabelTypes, _
ByVal AddLineNumbersToEmptyLines As Boolean, _
ByVal AddLineNumbersToEndOfProc As Boolean, _
ByVal Scope As vbLineNumbers_ScopeToAddLineNumbersTo, _
Optional ByVal thisProcName As String)
' USAGE RULES
' DO NOT MIX LABEL TYPES FOR LINE NUMBERS! IF ADDING LINE NUMBERS AS COLON TYPE, ANY LINE NUMBERS AS VBTAB TYPE MUST BE REMOVE BEFORE, AND RECIPROCALLY ADDING LINE NUMBERS AS VBTAB TYPE
Dim i As Long
Dim j As Long
Dim procName As String
Dim startOfProcedure As Long
Dim lengthOfProcedure As Long
Dim endOfProcedure As Long
Dim strLine As String
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
.CodePane.Window.Visible = False
If Scope = vbScopeAllProc Then
For i = 1 To .CountOfLines - 1
strLine = .Lines(i, 1)
procName = .ProcOfLine(i, vbext_pk_Proc) ' Type d'argument ByRef incompatible ~~> Requires VBIDE library as a Reference for the VBA Project
If procName <> vbNullString Then
startOfProcedure = .ProcStartLine(procName, vbext_pk_Proc)
bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc)
countOfProcedure = .ProcCountLines(procName, vbext_pk_Proc)
prelinesOfProcedure = bodyOfProcedure - startOfProcedure
'postlineOfProcedure = ??? not directly available since endOfProcedure is itself not directly available.
lengthOfProcedure = countOfProcedure - prelinesOfProcedure ' includes postlinesOfProcedure !
'endOfProcedure = ??? not directly available, each line of the proc must be tested until the End statement is reached. See below.
If endOfProcedure <> 0 And startOfProcedure < endOfProcedure And i > endOfProcedure Then
GoTo NextLine
End If
If i = bodyOfProcedure Then inprocbodylines = True
If bodyOfProcedure < i And i < startOfProcedure + countOfProcedure Then
If Not (.Lines(i - 1, 1) Like "* _") Then
inprocbodylines = False
PreviousIndentAdded = 0
If Trim(strLine) = "" And Not AddLineNumbersToEmptyLines Then GoTo NextLine
If IsProcEndLine(wbName, vbCompName, i) Then
endOfProcedure = i
If AddLineNumbersToEndOfProc Then
Call IndentProcBodyLinesAsProcEndLine(wbName, vbCompName, LabelType, endOfProcedure)
Else
GoTo NextLine
End If
End If
If LabelType = vbLabelColon Then
If HasLabel(strLine, vbLabelColon) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelColon)
If Not HasLabel(strLine, vbLabelColon) Then
temp_strLine = strLine
.ReplaceLine i, CStr(i) & ":" & strLine
new_strLine = .Lines(i, 1)
If Len(new_strLine) = Len(CStr(i) & ":" & temp_strLine) Then
PreviousIndentAdded = Len(CStr(i) & ":")
Else
PreviousIndentAdded = Len(CStr(i) & ": ")
End If
End If
ElseIf LabelType = vbLabelTab Then
If Not HasLabel(strLine, vbLabelTab) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelTab)
If Not HasLabel(strLine, vbLabelColon) Then
temp_strLine = strLine
.ReplaceLine i, CStr(i) & vbTab & strLine
PreviousIndentAdded = Len(strLine) - Len(temp_strLine)
End If
End If
Else
If Not inprocbodylines Then
If LabelType = vbLabelColon Then
.ReplaceLine i, Space(PreviousIndentAdded) & strLine
ElseIf LabelType = vbLabelTab Then
.ReplaceLine i, Space(4) & strLine
End If
Else
End If
End If
End If
End If
NextLine:
Next i
ElseIf AddLineNumbersToEmptyLines And Scope = vbScopeThisProc Then
End If
.CodePane.Window.Visible = True
End With
End Sub
Function IsProcEndLine(ByVal wbName As String, _
ByVal vbCompName As String, _
ByVal Line As Long) As Boolean
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
If Trim(.Lines(Line, 1)) Like "End Sub*" _
Or Trim(.Lines(Line, 1)) Like "End Function*" _
Or Trim(.Lines(Line, 1)) Like "End Property*" _
Then IsProcEndLine = True
End With
End Function
Sub IndentProcBodyLinesAsProcEndLine(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes, ByVal ProcEndLine As Long)
Dim procName As String
Dim startOfProcedure As Long
Dim endOfProcedure As Long
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
procName = .ProcOfLine(ProcEndLine, vbext_pk_Proc)
bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc)
endOfProcedure = ProcEndLine
strEnd = .Lines(endOfProcedure, 1)
j = bodyOfProcedure
Do Until Not .Lines(j - 1, 1) Like "* _" And j <> bodyOfProcedure
strLine = .Lines(j, 1)
If LabelType = vbLabelColon Then
If Mid(strEnd, Len(CStr(endOfProcedure)) + 1 + 1 + 1, 1) = " " Then
.ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 1) & strLine
Else
.ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 2) & strLine
End If
ElseIf LabelType = vbLabelTab Then
If endOfProcedure < 1000 Then
.ReplaceLine j, Space(4) & strLine
Else
Debug.Print "This tool is limited to 999 lines of code to work properly."
End If
End If
j = j + 1
Loop
End With
End Sub
Sub RemoveLineNumbers(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes)
Dim i As Long
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
'MsgBox ("nr of lines = " & .CountOfLines & vbNewLine & "Procname = " & procName)
'MsgBox ("nr of lines REMEMBER MUST BE LARGER THAN 7! = " & .CountOfLines)
For i = 1 To .CountOfLines
procName = .ProcOfLine(i, vbext_pk_Proc)
If procName <> vbNullString Then
If i > 1 Then
'MsgBox ("Line " & i & " is a body line " & .ProcBodyLine(procName, vbext_pk_Proc))
If i = .ProcBodyLine(procName, vbext_pk_Proc) Then inprocbodylines = True
If .Lines(i - 1, 1) <> "" Then
'MsgBox (.Lines(i - 1, 1))
End If
If Not .Lines(i - 1, 1) Like "* _" Then
'MsgBox (inprocbodylines)
inprocbodylines = False
'MsgBox ("recoginized a line that should be substituted: " & i)
'MsgBox ("about to replace " & .Lines(i, 1) & vbNewLine & " with: " & RemoveOneLineNumber(.Lines(i, 1), LabelType) & vbNewLine & " with label type: " & LabelType)
.ReplaceLine i, RemoveOneLineNumber(.Lines(i, 1), LabelType)
Else
If IsInProcBodyLines Then
' do nothing
'MsgBox (i)
Else
.ReplaceLine i, Mid(.Lines(i, 1), RemovedChars_previous_i + 1)
End If
End If
End If
Else
' GoTo NextLine
End If
NextLine:
Next i
End With
End Sub
Function RemoveOneLineNumber(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes)
RemoveOneLineNumber = aString
If LabelType = vbLabelColon Then
If aString Like "#:*" Or aString Like "##:*" Or aString Like "###:*" Or aString Like "####:*" Then
RemoveOneLineNumber = Mid(aString, 1 + InStr(1, aString, ":", vbTextCompare))
If Left(RemoveOneLineNumber, 2) Like " [! ]*" Then RemoveOneLineNumber = Mid(RemoveOneLineNumber, 2)
End If
ElseIf LabelType = vbLabelTab Then
If aString Like "# *" Or aString Like "## *" Or aString Like "### *" Or aString Like "#### *" Then RemoveOneLineNumber = Mid(aString, 5)
If aString Like "#" Or aString Like "##" Or aString Like "###" Or aString Like "####" Then RemoveOneLineNumber = ""
End If
End Function
Function HasLabel(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes) As Boolean
If LabelType = vbLabelColon Then HasLabel = InStr(1, aString & ":", ":") < InStr(1, aString & " ", " ")
If LabelType = vbLabelTab Then
HasLabel = Mid(aString, 1, 4) Like "# " Or Mid(aString, 1, 4) Like "## " Or Mid(aString, 1, 4) Like "### " Or Mid(aString, 1, 5) Like "#### "
End If
End Function
Function RemoveLeadingSpaces(ByVal aString As String) As String
Do Until Left(aString, 1) <> " "
aString = Mid(aString, 2)
Loop
RemoveLeadingSpaces = aString
End Function
Function WhatIsLineIndent(ByVal aString As String) As String
i = 1
Do Until Mid(aString, i, 1) <> " "
i = i + 1
Loop
WhatIsLineIndent = i
End Function
Function HowManyLeadingSpaces(ByVal aString As String) As String
HowManyLeadingSpaces = WhatIsLineIndent(aString) - 1
End Function
Module3:
Global allow_for_line_addition As String 'this is just so that you can automatically add linenumbers
Sub remove_line_numbering_all_modules()
'source: https://stackoverflow.com/questions/36791473/vba-getting-the-modules-in-workbook
'This code numbers all the modules in your .xlsm
Dim vbcomp As VBComponent
Dim modules As Collection
Set modules = New Collection
For Each vbcomp In ThisWorkbook.VBProject.VBComponents
'if normal or class module
If ((vbcomp.Type = vbext_ct_StdModule) Or (vbcomp.Type = vbext_ct_ClassModule)) Then
'V0:
RemoveLineNumbers wbName:=ThisWorkbook.name, vbCompName:=vbcomp.name, LabelType:=vbLabelColon
'V1:
'Call RemoveLineNumbers(ThisWorkbook.name, vbcomp.name)
End If
Next vbcomp
End Sub
Module4:
Global allow_for_line_addition As String 'this is just so that you can automatically add linenumbers
'This sub adds line numbers to all the modules after you have added the following line to every module
'add tools references microsoft visual basic for applications (5.3) as checked
'Source httpsstackoverflow.comquestions40731182excel-vba-how-to-turn-on-line-numbers-in-code-editor50368332#50368332
Sub add_line_numbering_all_modules()
'source: https://www.stackoverflow.com/questions/36791473/vba-getting-the-modules-in-workbook
'This code numbers all the modules in your .xlsm
Dim vbcomp As VBComponent
Dim modules As Collection
Set modules = New Collection
For Each vbcomp In ThisWorkbook.VBProject.VBComponents
'if normal or class module
If ((vbcomp.Type = vbext_ct_StdModule) Or (vbcomp.Type = vbext_ct_ClassModule)) Then
'V0:
Call AddLineNumbers(ThisWorkbook.name, vbcomp.name, vbLabelColon, True, True, vbScopeAllProc)
'v1
'Call AddLineNumbers(ThisWorkbook.name, vbcomp.name)
End If
Next vbcomp
End Sub
where you can either substitute "Book1.xlsm" with the name of your own workbook, or with thisworkbook (notice no ""), or vice versa.
*Note this worked in excel 2016, I have not tried it in 2013 yet.
^It is a modified version of Hemced's answer here., which in turn, looks a lot like Arich's answer.
°because sometimes you get an error if you cut lines out or move them around (e.g. put line 2440: above line 2303:). By removing and re-adding them, the line numbering is automatically correct again.
This Works for me...Add this to its own module. Calling the code will toggle line numbers on or off. Adding Module titles and/or procedure titles in quotes will update only the module or procedure named.
Option Compare Database
Option Explicit
Sub AddLineNumbers(Optional vbCompName As String, Optional vbCompSubName As String)
On Error Resume Next
DoCmd.Hourglass True
Application.VBE.ActiveVBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 0
Call ExecuteAddLineNumbers(vbCompName, vbCompSubName)
DoCmd.Hourglass False
End Sub
Sub ExecuteAddLineNumbers(Optional vbCompName As String, Optional vbCompSubName As String)
On Error GoTo Err_Handler
'create a reference to the Microsoft Visual Basic for Applications Extensibility library
Dim i As Long, j As Long, lineN As Long
Dim procName As String
Dim startOfProceedure As Long
Dim lengthOfProceedure As Long
Dim newLine As String
Dim objComponent As Object
Dim lineNumber As Long
Dim HasLineNumbers As Boolean
For Each objComponent In Application.VBE.ActiveVBProject.VBComponents
If (vbCompName = vbNullString Or objComponent.Name = vbCompName) And objComponent.Name <> _
Application.VBE.ActiveCodePane.CodeModule.Name) Then
Debug.Print objComponent.Name
With objComponent.CodeModule
.CodePane.Window.Visible = False
For i = 1 To .CountOfLines
'Debug.Print .ProcOfLine(i, vbext_pk_Proc)
If procName = "" And .ProcOfLine(i, vbext_pk_Proc) <> "" Then
procName = .ProcOfLine(i, vbext_pk_Proc)
'vbext_pk_Get Specifies a procedure that returns the value of a property.
'vbext_pk_Let Specifies a procedure that assigns a value to a property.
'vbext_pk_Set Specifies a procedure that sets a reference to an object.
'vbext_pk_Proc Specifies all procedures other than property procedures.
'type=vbext_ct_ClassModule
'type=vbext_ct_StdModule
'type=vbext_ct_Document
If objComponent.Type = vbext_ct_ClassModule Then
If InStr(.Lines(i + 1, 1), " Let ") > 0 Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Let)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Let)
ElseIf InStr(.Lines(i + 1, 1), " Get ") > 0 Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Get)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Get)
ElseIf InStr(.Lines(i + 1, 1), " Set ") > 0 Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Set)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Set)
Else
startOfProceedure = .ProcStartLine(procName, vbext_pk_Proc)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Proc)
End If
Else
startOfProceedure = .ProcStartLine(procName, vbext_pk_Proc)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Proc)
End If
lineNumber = 10
HasLineNumbers = .Find("## ", startOfProceedure + 1, 1, startOfProceedure + lengthOfProceedure - 1, 1, _
False, False, True)
End If
If (vbCompSubName = vbNullString And procName <> vbNullString) Or _
(vbCompSubName <> vbNullString And procName = vbCompSubName) Then
If startOfProceedure + 1 < i And i < startOfProceedure + lengthOfProceedure - 1 Then
newLine = RemoveOneLineNumber(.Lines(i, 1), HasLineNumbers)
If Trim(newLine) <> vbNullString Then
If Not HasLabel(newLine) And Not (.Lines(i - 1, 1) Like "* _") Then
If HasLineNumbers = False Then newLine = CStr(lineNumber) & vbTab & newLine
.ReplaceLine i, newLine
lineNumber = lineNumber + 10
ElseIf Not HasLineNumbers Then
.ReplaceLine i, vbTab & newLine
Else
.ReplaceLine i, newLine
End If
End If
ElseIf i = startOfProceedure + lengthOfProceedure - 1 Then
procName = ""
End If
Else
procName = ""
End If
Next i
.CodePane.Window.Visible = True
End With
End If
Next objComponent
Exit Sub
Err_Handler:
MsgBox (Err.Number & ": " & Err.Description)
End Sub
Function RemoveOneLineNumber(aString As String, HasLineNumbers As Boolean)
Dim i As Double
RemoveOneLineNumber = aString
i = ((Len(Trim(Str(Val(aString)))) / 4) - Int(Len(Trim(Str(Val(aString)))) / 4)) * 4
If aString Like "#*" Then
RemoveOneLineNumber = Space(i) & Mid(aString, InStr(1, aString, " ", vbTextCompare))
RemoveOneLineNumber = Right(aString, Len(aString) - 4)
ElseIf HasLineNumbers And aString Like " *" Then
RemoveOneLineNumber = Right(aString, Len(aString) - 4)
End If
End Function
Function HasLabel(ByVal aString As String) As Boolean
HasLabel = False
If Right(Trim(aString), 1) = ":" Or _
Left(Trim(aString), 3) = "Dim" Or _
Left(Trim(aString), 3) = "ReDim" Or _
Left(Trim(aString), 1) = "'" Or _
Left(Trim(aString), 6) = "Option" Or _
Left(Trim(aString), 5) = "Debug" Or _
Left(Trim(aString), 3) = "Sub" Or _
Left(Trim(aString), 11) = "Private Sub" Or _
Left(Trim(aString), 10) = "Public Sub" Or _
Left(Trim(aString), 8) = "Function" Or _
Left(Trim(aString), 12) = "End Function" Or _
Left(Trim(aString), 8) = "Property" Or _
Left(Trim(aString), 12) = "End Property" Or _
Left(Trim(aString), 7) = "End Sub" Then HasLabel = True
End Function
Any decent error handler will report more than just a line number. It will report the error ode, description and the module where it happened. Regardless whether ERL is repeating line numbers throughout your app, if you can't find the problem with the other clues reported, maybe you need a sabbatical. Or, hell, add a variable that increments a module level alpha code as an adjunct to the line number like "newERL = strProcLevel & ERL" to give you "A12345" as a line number.
This is not 100% tested, but using VBA extensibility you could do the following
Sub line_number(strModuleName As String)
Dim vbProj As VBProject
Dim vbComp As VBComponent
Dim cmCode As CodeModule
Dim intLine As Integer
Set vbProj = Application.VBE.ActiveVBProject
Set vbComp = vbProj.VBComponents(strModuleName)
Set cmCode = vbComp.CodeModule
For intLine = 2 To cmCode.CountOfLines - 1
cmCode.InsertLines intLine, intLine - 1 & cmCode.Lines(intLine, 1)
cmCode.DeleteLines intLine + 1, 1
Next intLine
End Sub
This gives the results before and after as below, altering in this way is not recommended though.