So when my F7 value changes from “george” or blank to something else, a message box appears.

Here is the code:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Static blnDoneThis As Boolean
    Dim varOldValue As Variant
    Dim varNewValue As Variant
    
    'initialize a variable to regulate the Worksheet_Change event
    If blnDoneThis Then
        blnDoneThis = False
        Exit Sub
    End If
    
    'get the new value
    varNewValue = Target.Value
    
    'set our regulator to true
    blnDoneThis = True
    
    'time to get the old value and store it in a variable
    Application.Undo

    varOldValue = Target.Value
    
    'tell the regulator, it's ok
    blnDoneThis = True
    
    'check if the month has changed from the old value
    If varNewValue <> varOldValue Then
        MsgBox " value has changed"
    End If
    
    'set the cell equal to the new value
    Target.Value = varNewValue
    
    
End Sub

Let me know if you have questions.

The post How To Run Macro (VBA) When The Cell Value Changes appeared first on My Blog.

It shows how to parse a JSON string with VBA.

The impetus for this was to access the price data for various coins on coinmarketcap.com

…and to get the price data for 50+ coins required getting a coinmarketcap api, and resulted in a JSON string.

I just included the essential stuff below, maybe it will help you out too.

Go here for more information: https://medium.com/swlh/excel-vba-parse-json-easily-c2213f4d8e7a

'-------------------------------------------------------------------
' VBA JSON Parser
'-------------------------------------------------------------------
Option Explicit
Private p&, token, dic
Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function
Function ParseObj(key$)
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{":  ParseObj key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If
                
            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function
Function ParseArr(key$)
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$)
    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
    Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
  Dim c&, m, n, v
  With CreateObject("vbscript.regexp")
    .Global = bGlobal
    .MultiLine = False
    .IgnoreCase = True
    .Pattern = Pattern
    If .test(s) Then
      Set m = .Execute(s)
      ReDim v(1 To m.Count)
      For Each n In m
        c = c + 1
        v(c) = n.Value
        If bGroup1Bias Then If Len(n.submatches(0)) Or n.Value = """""" Then v(c) = n.submatches(0)
      Next
    End If
  End With
  RExtract = v
End Function
Function ArrayID$(e)
    ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key
End Function
Function ListPaths(dic)
    Dim s$, v
    Dim intRow As Integer
    
    For Each v In dic
        s = s & v & " --> " & dic(v) & vbLf
    Next
    Debug.Print s
    
End Function

'This is my contribution!
Sub StartHere()
    Dim strURL As String
    
    strURL = ThisWorkbook.Path & "\currencies.txt"

    Dim strFileContent As String
    Dim intFile As Integer
    
    intFile = FreeFile
    Open strURL For Input As #intFile
    strFileContent = Input(LOF(intFile), intFile)
    Close #intFile

    Set dic = ParseJSON(strFileContent)
    Debug.Print ListPaths(dic)
End Sub

Go to this post to see the post for the Load Text File:
http://www.vbastring.com/blog/how-to-load-a-text-file-in-excel-vba-with-load-data-infile/

Here is a bit of the input file and the same bit when run through the parser:

The post How To Parse JSON With Excel VBA appeared first on My Blog.

So for reference sake, here is something easy.

This is how to load a local text file into a variable, so you can process it.

For example:

So you have some JSON file, and you put the JSON formatted text locally in a text file so you can experiment on parsing it before you actually run a lot of web queries.

Well here is how to do it:

Sub LoadFile()
    Dim strURL As String
    
    'this is the text file in the directory of your spreadsheet   
    strURL = ThisWorkbook.Path & "\currencies.txt"
    
    Dim strFileContent As String
    Dim intFile As Integer
    
    intFile = FreeFile
    Open strURL For Input As #intFile
    strFileContent = Input(LOF(intFile), intFile)
    Close intFile

End Sub

Now the contents of your text file are in the string strFileContent.

Questions?

The post How To Load A Text File In Excel VBA With Load Data Infile appeared first on My Blog.

Basically it can be summarized by titling it “automatic invoice number generator excel”

That is what this is:

This can be filled out with user form, but all the data ultimately gets entered into the underlying spreadsheet so we’ll skip the user form part (let me know if you actually want to see it).

Column A is just a date (“TODAY’S DATE”).
Column B is a formula based on column A, “=YEAR(A3)”. (“YEAR”)
Column C is a formula based on column B, “=RIGHT(B2,2)”. (“LAST TWO DIGITS OF YEAR”)
Column D is just the “Month” function based on Column A, but the single digit months are padded “=IF(LEN(MONTH(A2))<10,"0" & MONTH(A2),MONTH(A2))". (“MONTH”)

and finally Column “E” is the “INVOICE NO” generated with the following code:

'code by loeblcomservices.com
'713-409-7041


Sub Rectangle1_Click()
    
    Dim intActiveRow As Integer
    Dim lngLastRow As Long
    Dim strCustomerID As String
    Dim strInvoiceID As String
    
    intActiveRow = ActiveCell.Row
    lngLastRow = FindLastRow("A")

    strInvoiceID = GetNextInvoiceID(Range("C" & intActiveRow), Range("D" & intActiveRow))
    
    'write the new Invoice ID
    Range("E" & intActiveRow) = strInvoiceID
End Sub


Function FindLastRow(WhichColumn As String) As Long
    
    'FINDS THE LAST ROW BASED ON THE COLUMN LETTER <---
    
    Dim lngLastRow As Long
    
    'move to the last row on the worksheet and find the last used cell.
    
    With ActiveSheet
        lngLastRow = ActiveSheet.Cells(1048576, WhichColumn).End(xlUp).Row
    End With

    FindLastRow = lngLastRow

End Function


Function GetNextInvoiceID(strYear, strMonth) As String
    Dim intCounter As Integer
    Dim varPos As Variant
    Dim lngLastRow As Long
    Dim strCounter As String
    Dim blnFound As Boolean
    
   
    lngLastRow = FindLastRow("A")
    
    'invoice id's stop at 99, add more if you have more than 99 invoices per month
    For intCounter = 1 To 100
        
        'pad the numbers under 10
        If Len(intCounter) < 10 Then
            strCounter = "0" & intCounter
        Else
            strCounter = intCounter
        End If
        
        'formulate the trial invoice id to search the list for
        strInvoiceID = strYear & strMonth & strCounter
       
        'if the value is already in the list, the count will be greater than zero.
        intct = Application.WorksheetFunction.CountIf(Range("E1:E" & lngLastRow), strInvoiceID)
        If intct > 0 Then
            'do nothing, because it already is used
        Else
            'it's available, so use it and exit the function
           GetNextInvoiceID = strInvoiceID
           Exit For
        End If
    Next

End Function

The real “work horse” here is the function “GetNextInvoiceID”.

It uses a for loop to search Column “E” for evidence that the invoice number was used, and it will use the next higher number instead.

What’s also worth noting is that you can use your normal Excel worksheet functions in your VBA by using, the Application.Worksheetfunction syntax: ex. Application.WorksheetFunction.CountIf

Let me know if you have questions.

The post Automatic Invoice Number Generator Excel VBA Project appeared first on My Blog.

It is actually a response from a question I received:

“Can you let me know how to check if a particular value is present in a named list. Or in a different worksheet”

You can use the “countif” function.

ex. =countif({value to look for}, {range to look in})

if the result is greater than zero, the value is in the range, if zero then it’s not there.

Take a look at the above example.

You’ll see that the built in countif Excel function returns a value greater than zero if the value be sought after is in the list (range), and zero if it’s not.

Now how do you use the countif function with VBA?

Function GetNextInvoiceID(strYear, strMonth) As String
    Dim intCounter As Integer
    Dim varPos As Variant
    Dim lngLastRow As Long
    Dim strCounter As String
    Dim blnFound As Boolean
    
   
    lngLastRow = FindLastRow("A")
    
    
    For intCounter = 1 To 100
        If Len(intCounter) < 10 Then
            strCounter = "0" & intCounter
        Else
            strCounter = intCounter
        End If
        strInvoiceID = strYear & strMonth & strCounter
        
        blnFound = False
        
        intct = Application.WorksheetFunction.CountIf(Range("F1:F" & lngLastRow), strInvoiceID)
        If intct > 0 Then

        Else

           GetNextInvoiceID = strInvoiceID
           Exit For
        End If
        
    
    Next

End Function

Function FindLastRow(WhichColumn As String) As Long
    
    'FINDS THE LAST ROW BASED ON THE COLUMN LETTER <---
    
    Dim lngLastRow As Long
    
    'move to the last row on the worksheet and find the last used cell.
    
    With ActiveSheet
        lngLastRow = ActiveSheet.Cells(1048576, WhichColumn).End(xlUp).Row
    End With

    FindLastRow = lngLastRow

End Function

* Here I'm using the "countif" function, and returning the value to a variable called "intct" :

intct = Application.WorksheetFunction.CountIf(Range("F1:F" & lngLastRow), strInvoiceID)

Questions? Contact Me

The post How To Have Excel Check If Range Of Cells Contains Specific Text With VBA appeared first on My Blog.

https://www.youtube.com/watch?v=Z9kt86I_rq0&feature=em-comments

*This gives an example of how to get notified of a change made to one of the worksheet cells.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Static blnDoneThis As Boolean
    Dim varOldValue As Variant
    Dim varNewValue As Variant
    
    'initialize a variable to regulate the Worksheet_Change event
    If blnDoneThis Then
        blnDoneThis = False
        Exit Sub
    End If
    
    'get the new value
    varNewValue = Target.Value
    
    'set our regulator to true
    blnDoneThis = True
    
    'time to get the old value and store it in a variable
    Application.Undo

    varOldValue = Target.Value
    
    'tell the regulator, it's ok
    blnDoneThis = True
    
    'check if the month has changed from the old value
    If Month(varNewValue) <> Month(varOldValue) Then
        MsgBox " Month has changed"
    End If
    
    'set the cell equal to the new value
    Target.Value = varNewValue
    
    
End Sub

The post Checking If Month Changed – Excel VBA Old Value Cell Target appeared first on My Blog.

Here is the “pseudocode” (my though process, which you should do in order to structure your thoughts):

1. loop through the cells
2. select c13:L16 -> copy
3. count 6 rows -> paste
4. repeat until row 1213

A range copy and paste in this case works because there are absolute references.

The formula will be update to the current row when the past is made, but when the “$” is used, an absolute reference is made, and we will be referencing just that cell, so everything will calculate correctly.

In this case, row 12 in D12 will change (it’s relative (like the culture likes to believe )), but we row 5 WILL NOT change because it is absolutely referenced

Anyway here is how it turns out all together:

Sub CopyAndPaste()
    Dim intRow As Integer
    Dim rngSelection As Range
    Dim intCounter As Integer

    Set rngSelection = Sheets("Costs").Range("c13:L16")
    rngSelection.Select
    rngSelection.Copy
    
    'initialize intCounter
    intCounter = 12 + 6
    
    For intRow = 12 To 1213

        If intRow = intCounter Then
            Sheets("Costs").Range("C" & intRow).Select
            
            intCounter = intRow + 5

            ActiveSheet.Paste

        End If
        
    Next
End Sub

Questions?

The post VBA Copy And Paste Sample appeared first on My Blog.

You need the file names from the picture, but you can use an OCR (Object Character Resolution) to list the files on the image because a lot of the text shows up like garbage.

So the next bright idea you come up with is to list the files in the folder, by sending the user a VBA file with a button they can click on, select the folder, loop through the files in the folder, and print the files on a worksheet in the workbook.

Then the user can save the workbook and send it back to you.

How about that

Here’s the code to do such a thing:

Dim m_intRow As Integer

Sub Main()
    Dim fsoFileSystem As Object
    Dim strMainFolder As String
    
    m_intRow = 1

    ' Open the select folder prompt
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            strMainFolder = .SelectedItems(1)
        End If
    End With

    If strMainFolder <> "" Then ' if a file was chosen
        Set fsoFileSystem = CreateObject("Scripting.FileSystemObject")
        DoSubFolders fsoFileSystem.GetFolder(strMainFolder)
    Else
        MsgBox "You need to select a file folder first"
    End If
 
End Sub
 
Sub DoSubFolders(Folder)
    Dim objSubFolder As Object
 
    For Each objSubFolder In Folder.SubFolders
        
        Debug.Print "*****************************************"
        Debug.Print "SubFolder= " & objSubFolder.Name
        Debug.Print "*****************************************"
        

        DoSubFolders objSubFolder
    Next
    Dim objFile As Object
    For Each objFile In Folder.Files
        ' Operate on each file
        'Debug.Print "FileName= " & objFile.Name
        Range("A" & m_intRow) = objFile.Name
        m_intRow = m_intRow + 1
    Next
End Sub

Let me know if you have questions.

The post How To Use VBA To Loop Through The Files In A Folder appeared first on My Blog.

I wanted to know as how to trigger an event when a cell value is deleted?

(a comment to this post’s video: http://www.vbastring.com/blog/how-to-run-a-macro-when-cell-value-changes-in-excel-vba/)

So we are going to trigger an Excel VBA event when a value is deleted from a cell.

In the above screen shot we have a fake list of names in column A of the worksheet.

We are deleting the value from Cell “A4”, and we are adding a little confirmation message to confirm to the user that that’s what they want to do.

If we click “Yes”, the old value (existing value) gets “deleted” (substituted) with the current value (a blank value).

Private Sub Worksheet_Change(ByVal Target As Range)
    'this was modified from an idea from https://stackoverflow.com/questions/4668410/how-do-i-get-the-old-value-of-a-changed-cell-in-excel-vba
    
    
    Static blnAlreadyBeenHere As Boolean
    Dim intAnswer As Integer
    
    'This piece avoid to execute Worksheet_Change again
    If blnAlreadyBeenHere Then
        blnAlreadyBeenHere = False
        Exit Sub
    End If
    
    'Now, we will create variant variables store the old and new value
    Dim varOldValue As Variant
    Dim varNewValue As Variant
    
    'Use this to store new value
    varNewValue = Target.Value
    
    'Use the 'undo' functionality to retrieve the old value
    
    'Here we will tell the Worksheet_Change event to avoid calling a new Worksheet_Change execution
    blnAlreadyBeenHere = True
    
    Application.Undo
    
    'now we can store the old value
    varOldValue = Target.Value
    
    'Now rewrite the cell with the new value stored earlier
    
    'Here again we will tell the Worksheet_Change event to avoid calling a new Worksheet_Change execution
    blnAlreadyBeenHere = True
    Target.Value = varNewValue
    
    '***************************************************************
    'Now we have the 2 values stored in varOldValue and varNewValue
    '***************************************************************

    'Check if the cell value was deleted:
    
    If varNewValue = "" Then
        intAnswer = MsgBox("Delete the current cell's value?", vbYesNo, "Confirmation")
        If intAnswer = vbNo Then
            'Here again we will tell the Worksheet_Change event to avoid calling a new Worksheet_Change execution
            blnAlreadyBeenHere = True
            
            'set the deleted cell value to what it was before the deletion. (couldn't use undo)
            Target.FormulaR1C1 = varOldValue
            
            'Or, fire the event you want, like logging the deletion in another file.
            
        End If
    Else
        'Just for reference:
        Debug.Print "oldval: " & varOldValue & ", newval: " & varNewValue
    End If


End Sub

Do you have questions?

Let me know. Also, share this with someone else.

The post How To Trigger An Excel VBA Event When Cell Value Is Deleted appeared first on My Blog.

https://www.youtube.com/watch?v=UspqR0g4XyU

The comment was:

How would you do this for the last name? Or second last name? How to find the space after the first space, and the space after the second space? And then, if there is no first space or there is a first space but no second space, then skip the function instead of error?

So the video was put out a few years back, and so I’m going to show you a newer way of handling this.

Here is the worksheet and a little explanation:

Basically, this is going to be one function, and one of my arguments is going to decide whether we need to parse the first name, last name, or middle name.

…And here are the answers to her questions:

How would you do this for the last name?

Function ParseName(ParseText As String, NamePart As String)
    Dim strName As String
        
    Select Case NamePart
          
        Case "Last"
            'gets the name after the last space
            strName = Right(ParseText, Len(ParseText) - InStrRev(ParseText, " "))
        
    End Select
    
    ParseName = strName
    
End Function

Or second last name?

Since that may mean “middle” name, I’m going to show that.

The following will answer these 2 questions as well:

How to find the space after the first space, and the space after the second space?

And then, if there is no first space or there is a first space but no second space, then skip the function instead of error?

Function ParseName(ParseText As String, NamePart As String)
    Dim strName As String
    
    Dim varName As Variant
    Dim intSpaceCount As Integer
    
    Dim intFirstSpace As Integer
    Dim intLastSpace As Integer
    
    Select Case NamePart

            
        Case "Middle"
            'parse the entire string by all the spaces in the string using the split function.
            'then we will parse the check if there is a middle name based on the space count.

            varName = Split(ParseText, " ")
            
            For intSpaceCount = 0 To UBound(varName)
                If intSpaceCount = 1 Then
                    'no middle name
                End If
                If intSpaceCount = 2 Then
                    'get middle name
                    intFirstSpace = InStr(ParseText, " ")
                    intLastSpace = InStrRev(ParseText, " ")
                    
                    strName = Mid(ParseText, intFirstSpace + 1, intLastSpace - intFirstSpace - 1)
                End If
            Next
    End Select
    
    ParseName = strName
    
End Function

Here’s the code all together:

Function ParseName(ParseText As String, NamePart As String)
    Dim strName As String
    
    Dim varName As Variant
    Dim intSpaceCount As Integer
    
    Dim intFirstSpace As Integer
    Dim intLastSpace As Integer
    
    Select Case NamePart
        
        Case "First"
            'gets the name before the first space
            strName = Left(ParseText, InStr(ParseText, " "))
            
        Case "Middle"
            varName = Split(ParseText, " ")
            
            For intSpaceCount = 0 To UBound(varName)
                If intSpaceCount = 1 Then
                    'no middle name
                End If
                If intSpaceCount = 2 Then
                    'get middle name
                    intFirstSpace = InStr(ParseText, " ")
                    intLastSpace = InStrRev(ParseText, " ")
                    
                    strName = Mid(ParseText, intFirstSpace + 1, intLastSpace - intFirstSpace - 1)
                End If
            Next
    
        Case "Last"
            'gets the name after the last space
            strName = Right(ParseText, Len(ParseText) - InStrRev(ParseText, " "))
        
    End Select
    
    ParseName = strName
    
End Function

Let me know if you have any questions, and make sure you share this with someone else.

The post How To Have VBA Parse A Name String appeared first on My Blog.