Lutfor Rahman Shimanto

Hello Charlotte Fahey
Thank you for reporting on this fascinating issue. I experience the same problems when a postal code begins with 0, and it is essential to preserve the leading zero when entering data into the system or application.
The Postal Code column must be formatted as text. Following that, insert the desired data.

Now, adhere to the methods mentioned in this article. Ideally, you will observe the desired results.

Regards
Lutfor Rahman Shimanto

Hello DEBB WOLFE
We appreciate your comment. I understand your difficulty, and you can avoid the issue by importing the CVS file into the existing worksheet.
Change the column type in the Power Query window to text, as this article mentions. Next, select the Home tab. Select Close & Load and then Close & Load To at a later time.

As a result, the Import Data window will display. Check the Existing Worksheet and then press OK.

Thus, you will be able to solve the problem.
Regards
Lutfor Rahman Shimanto

Hello ABIGAYLE PAULSON
Thank you for reporting on this fascinating issue. I have reviewed this article and found an interesting idea to solve your problem. For illustration, let’s walk through 2nd Example. Filtering the dataset (Sheet3) based on cell values on another sheet (Sheet4). The context filters the dataset for Apple or Tomato products.
VBA Code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim product1, product2 As Range
        
    If Target.Worksheet.Name = "Sheet4" And (Target.Address = "$C$2" Or Target.Address = "$E$2") Then
        With Worksheets("Sheet4")
            Set product1 = .Range("C2")
            Set product2 = .Range("E2")
        End With
        With Worksheets("Sheet3")
            With .Range("B4:G13")
                .AutoFilter Field:=3, Criteria1:=product1, Operator:=xlOr, Criteria2:=product2
            End With
        End With
    End If
End Sub

If the changed cell is either C2 or E2, the macro will execute and filter the data in “Sheet3” based on the new values in these cells. Note that the Worksheet_Change event must be placed in the code module for the “Sheet4” worksheet.
The changes we must make to the original code to create the auto-filtering behavior:

1) We have to add a Private Sub Worksheet_Change(ByVal Target As Range) procedure to the code module for the “Sheet4” worksheet. This procedure runs automatically whenever a cell value is changed on this worksheet.

2) We can add an If statement to check whether the changed cell is in Sheet4 and C2 or E2. If so, the macro continues executing; if not, it exits without doing anything.

3) We need to move the Dim statements for product1 and product2 inside the If statement, so they are only declared if the macro is going to run.

4) The rest of the macro code is the same as the original code, so it will apply the same filter to “Sheet3” based on the new values in “Sheet4” whenever the cell value changes.

By adding this Worksheet_Change procedure to the code module, the macro will run automatically whenever a change is made to the specified cells in “Sheet4” without manually opening and running the macro.
Regards
Lutfor Rahman Shimanto

Hello Sherry

Thanks for reaching out! Providing an ultimate solution without glancing at your Excel file is difficult. However, I suggest several things you may check to ensure the multi-selection drop-down works properly.

Ensure you have created named ranges for your dataset as described. Make sure that the strDVList variable correctly references your named range. To ensure that the named range CityNames is correctly referenced by strDVList, you can call the InitializeDVList subroutine in the Worksheet_SelectionChange event before it tries to use strDVList.

So, double-click on the user form and replace the existing code with the following:

Sub InitializeDVList()
    strDVList = "CityNames"
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rngDV As Range
    Dim oldVal As String
    Dim newVal As String
    Dim strList As String
    On Error Resume Next
    Application.EnableEvents = False
    Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo exitHandler
    If rngDV Is Nothing Then GoTo exitHandler
    If Not Intersect(Target, rngDV) Is Nothing Then
        If Target.Validation.Type = 3 Then
            Call InitializeDVList
            frmDVList.Show
        End If
    End If
exitHandler:
    Application.EnableEvents = True
End Sub

Private Sub UserForm_Initialize()
    Me.lstDV.RowSource = strDVList
End Sub

Private Sub cmdOK_Click()
    Dim strSelItems As String
    Dim lCountList As Long
    Dim strSep As String
    Dim strAdd As String
    Dim bDup As Boolean
    On Error Resume Next
    strSep = ", "
    With Me.lstDV
        For lCountList = 0 To .ListCount - 1
            If .Selected(lCountList) Then
                strAdd = .List(lCountList)
            Else
                strAdd = ""
            End If
            If strSelItems = "" Then
                strSelItems = strAdd
            Else
                If strAdd <> "" Then
                    strSelItems = strSelItems & strSep & strAdd
                End If
            End If
        Next lCountList
    End With
    With ActiveCell
        If .Value <> "" Then
            .Value = ActiveCell.Value & strSep & strSelItems
        Else
            .Value = strSelItems
        End If
    End With
    Unload Me
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

Hopefully, these ideas will help you overcome your situation. Good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Onkar

Thanks for your invaluable feedback!

When copying data from the Excel files, you wanted a sub-procedure to copy only the header from the first file and skip the header row for the subsequent files. Currently, you are getting the runtime error 1004 with the existing code, which is typically caused by issues with object references or out-of-bound ranges.

Don’t worry! I have reviewed your problem and improved the existing sub-procedure to fulfil your goal. Please check the following:

Improved Excel VBA Sub-procedure:

Sub ExtractMergeDataFromMultipleFiles()

    Dim fileDialog As fileDialog
    Dim selectedFiles As FileDialogSelectedItems
    Dim wBook As Workbook
    Dim currentRow As Long
    Dim row As Long
    Dim col As Long
    Dim i As Long
    Dim file As Variant
    Dim firstFile As Boolean

    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    fileDialog.AllowMultiSelect = True
    fileDialog.Title = "Select Excel Files"
    fileDialog.Filters.Clear
    fileDialog.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xlsb; *.xls"
    
    If fileDialog.Show = -1 Then
        Set selectedFiles = fileDialog.SelectedItems
    Else
        Exit Sub
    End If
    
    currentRow = 1
    firstFile = True
    
    For Each file In selectedFiles
        Set wBook = Workbooks.Open(file)
        
        With wBook.Sheets(1)
            If firstFile Then
                row = 1
                firstFile = False
            Else
                row = 2
            End If
            
            Do Until .Cells(row, 1).Value = vbNullString
                col = .Cells(row, .Columns.Count).End(xlToLeft).Column
                
                For i = 1 To col
                    ThisWorkbook.Sheets(1).Cells(currentRow, i).Value = .Cells(row, i).Value
                Next i
                
                row = row + 1
                currentRow = currentRow + 1
            Loop
        End With
        
        wBook.Close False
    Next file
    
    Set wBook = Nothing
    Set fileDialog = Nothing
    Set selectedFiles = Nothing

End Sub

Hopefully, with the code, you will not get any runtime error, and you will be able to copy the header only from the first filter, skipping the header row for the other files. I have attached the solution workbook used to solve your problem. You can download it for better understanding. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Shaz

Thanks for your question! You want to link checkboxes directly to the same cells where these are presented.

To do so, insert a check box and edit the text like described here. Next, select the checkbox by holding the Ctrl key. Now, type the cell reference in the formula bar where the checkbox is located. Please check the following:

You can download the workbook used to solve your problem: https://www.exceldemy.com/wp-content/uploads/2024/06/Shaz-SOLVED.xlsx

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Lisa Hoffer

Thanks for visiting our blog and sharing such an interesting question. You wanted an Excel VBA sub-procedure to clear the contents of non-contiguous rows. I have developed such a sub-procedure to fulfil your goal. Please check the following:

Excel VBA Sub-procedure:

Sub ClearSpecificRows()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sunday Report")
    
    Dim rowsToClear As Variant
    rowsToClear = Array(4, 7, 10, 14)
    
    Dim i As Integer
    For i = LBound(rowsToClear) To UBound(rowsToClear)
        ws.Rows(rowsToClear(i)).ClearContents
    Next i
    
    MsgBox "Contents cleared for rows 4, 7, 10, and 14 in 'Sunday Report'"

End Sub

Hopefully, you have found the VBA macro you were looking for. I have attached the workbook used to solve your problem. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Jess

Thanks for your comment! Only leading spaces typically don’t affect the SUM function in most Excel versions. However, leading spaces can indeed cause numbers to be treated as text in some Excel versions like yours. It is great to hear that removing leading spaces resolved the issue for you.

I am sharing another exciting solution for summing numbers with inconsistent spaces using an Excel formula. Please check the following:

Excel Formulas (using SUM, VALUE, and SUBSTITUTE functions): =SUM(VALUE(SUBSTITUTE($B$2:$B$7, " ", "")))

Hopefully, you will like the solution. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Dear Doug

Thanks for visiting our blog and sharing an exciting problem. You needed help with some Excel VBA sub-procedures to move rows from the Account sheet to the Archive sheet under specific conditions. You want this to happen only when you click a button on the Metrics sheet and turn it on. The conditions are as follows: if a row in the Account sheet has Closed or Archive in its Status column. You also wanted a pop-up to confirm the action before moving a row. Additionally, the row should be deleted from the Account sheet after moving.

Don’t worry! I have reviewed your requirements and demonstrated the situation within an Excel file with a suitable dataset. I have solved the problem with the help of some Excel VBA sub-procedures. Please check the following:

Excel VBA Sub-procedures:

Dim isMacroEnabled As Boolean

Sub MoveRowsBasedOnConditions()
    
    If Not isMacroEnabled Then Exit Sub
    
    Dim wsAccount As Worksheet
    Dim wsArchive As Worksheet
    Dim rg As Range
    Dim cell As Range
    Dim lastRowAccount As Long
    Dim lastRowArchive As Long
    Dim userResponse As VbMsgBoxResult

    Set wsAccount = Worksheets("Account")
    Set wsArchive = Worksheets("Archive")

    userResponse = MsgBox("Are you sure?", vbOKCancel, "Confirm Action")
    
    If userResponse = vbCancel Then Exit Sub

    lastRowAccount = wsAccount.Cells(wsAccount.Rows.Count, "A").End(xlUp).Row
    lastRowArchive = wsArchive.Cells(wsArchive.Rows.Count, "A").End(xlUp).Row + 1

    Set rg = wsAccount.Range("A2:A" & lastRowAccount)
    
    For Each cell In rg
    
        If cell.Offset(0, 2).Value = "Closed" Or cell.Offset(0, 2).Value = "Archive" Then
            
            cell.EntireRow.Copy Destination:=wsArchive.Range("A" & lastRowArchive)
            lastRowArchive = lastRowArchive + 1
        
        End If
        
    Next cell
    
    Call DeleteRowsBasedOnCellValue

End Sub

Sub DeleteRowsBasedOnCellValue()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    Set ws = Worksheets("Account")
    
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    For i = lastRow To 2 Step -1
        If ws.Cells(i, 3).Value = "Closed" Or ws.Cells(i, 3).Value = "Archive" Then
            ws.Rows(i).Delete
            
        End If
    Next i

End Sub


Sub ToggleMacro()
    
    Dim wsMetrics As Worksheet
    Set wsMetrics = Worksheets("Metrics")
    
    isMacroEnabled = Not isMacroEnabled
    
    If isMacroEnabled Then
        wsMetrics.Buttons("btnToggle").Caption = "Macro is ON"
    Else
        wsMetrics.Buttons("btnToggle").Caption = "Macro is OFF"
    End If

End Sub

Sub CreateButton()
    
    Dim wsMetrics As Worksheet
    Dim btn As Button

    Set wsMetrics = Worksheets("Metrics")

    Set btn = wsMetrics.Buttons.Add(10, 10, 100, 30)
    btn.Name = "btnToggle"
    btn.Caption = "Macro is OFF"
    btn.OnAction = "ToggleMacro"
    
    isMacroEnabled = False

End Sub

Hopefully, you have found the solution you were looking for. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear, Thanks for pointing out the fact! You are right. The Alignment tab in the Format Cells dialog box is unavailable when setting up conditional formatting rules. So, using the conditional formatting option for text alignment is impossible.

Don’t worry! There is an idea of using an Excel VBA event procedure. Please check the following:

The event procedure will trigger when range B2:B7 is changed. If the cell value is Red, it will apply left alignment. For Blue, it will be center alignment; for the other values, it will apply left alignment.

Excel VBA Event Procedure:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cell As Range

    Dim targetRange As Range
    Set targetRange = Me.Range("B2:B7")

    If Not Intersect(Target, targetRange) Is Nothing Then
        For Each cell In Intersect(Target, targetRange)

            If cell.Value = "Red" Then
                cell.HorizontalAlignment = xlLeft
            ElseIf cell.Value = "Blue" Then
                cell.HorizontalAlignment = xlCenter
            Else
                cell.HorizontalAlignment = xlRight
            End If
        Next cell
    End If

End Sub

Hopefully, the solution will fulfil your goal. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Naqavi

Thanks for your compliment! Your appreciation means a lot to us.

Regards
ExcelDemy

Dear Annie

Thanks for visiting our blog and sharing an important fact! You are right that the holiday range reference shifts when you copy the formula. You need to use absolute references for the holiday range to fix the issue. Another improvement you can consider is not keeping the holiday list and start date or next working dates in the same column. Assume the start date and next working date data are in columns B and C; the holiday list is in column E.

Don’t worry! I have demonstrated an improved Excel file to overcome the situation. Please check the following:

Follow these steps:

1. Select cell C5.
2. Insert the following formula: =WORKDAY(B5,7,$E$5:$E$7)
   
3. Select the C5:C9 range and press Ctrl+D.
   // After pressing Ctrl+D, you will get the output like the following:
   

Hopefully, you have found the solution you were looking for. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Mary

Thanks for visiting our blog and sharing your problem. The issue you are facing is due to the RAND function, which generates a new random number every time the worksheet recalculates.

To prevent the problem, copy the random values, then use Paste Special and paste them back as Values. The idea should keep your random names stable.

Regards
ExcelDemy

Hello Luke

Thanks for sharing your problem with such clarity. Based on your requirements, you can use the following Excel VBA Sub-procedure to fulfil your goal.

Excel VBA Sub-procedure:

Sub ExcelToCSV()

    Dim rng As Range, row As Range, cell As Range
    Dim dqt As String, dlim As String, text As String
    Dim file As Variant
    On Error Resume Next

    Set rng = ActiveSheet.Range("A3:B319, D3:F319, I3:I319")

    If rng Is Nothing Then Exit Sub

    file = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
    dlim = Application.International(xlListSeparator)
    Open file For Output As #1
    For Each row In rng.Rows
        dqt = ""
        For Each cell In row.Cells

            If cell.Column = 1 Or cell.Column = 2 Or cell.Column = 4 Or cell.Column = 5 Or cell.Column = 6 Or cell.Column = 9 Then
                dqt = dqt & """" & cell.Value & """" & dlim
            Else
                dqt = dqt & cell.Value & dlim
            End If
        Next
        While Right(dqt, 1) = dlim
            dqt = Left(dqt, Len(dqt) - 1)
        Wend
        Print #1, dqt
    Next
    Close #1
    If Err = 0 Then MsgBox "The CSV file has been saved to: " & file, vbInformation

End Sub

Hopefully, the sub-procedure will be helpful. Stay blessed.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Nancy Cruz

Thanks for visiting our blog! And also sharing your problem with such clarity. I have reviewed your issue with date formatting and come up with a solution. Please check the following:

Follow these steps:

1. Select column A and go to Home.
2. Under the Cells group, expand Format and click on Format Cells.
   // As a result, the Format Cells window will open up.
3. In the Format Cells window,
   • Go to Number and click on Custom.
   • Insert the following formatting code in the Type section: mm/dd
   • Hit OK.
     // As a result, the date will be formatted as expected like the following:
     
4. Now, select the intended date range and apply the desired sorting option.
   

Hopefully, you have found the solution you were looking for. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Rahul Dixit

Thanks for visiting our blog and sharing such an exciting problem! I have reviewed your problem and come up with an Excel VBA User-defined function. Please check the following:

Excel VBA Code:

Function ConvertNumbersToLetters(inputStr As String) As String

    Dim numArray() As String
    Dim resultArray() As String
    Dim i As Integer
    Dim currentNum As String
    Dim convertedNum As String
    
    numArray = Split(inputStr, ",")
    ReDim resultArray(LBound(numArray) To UBound(numArray))
    
    For i = LBound(numArray) To UBound(numArray)
        currentNum = Trim(numArray(i))
        convertedNum = ""
        Dim j As Integer
        Dim currentChar As String
        
        For j = 1 To Len(currentNum)
            currentChar = Mid(currentNum, j, 1)
            Select Case currentChar
                Case "1"
                    convertedNum = convertedNum & "A"
                Case "2"
                    convertedNum = convertedNum & "B"
                Case "3"
                    convertedNum = convertedNum & "C"
                Case "4"
                    convertedNum = convertedNum & "D"
                Case "5"
                    convertedNum = convertedNum & "E"
                Case "6"
                    convertedNum = convertedNum & "F"
                Case "7"
                    convertedNum = convertedNum & "G"
                Case "8"
                    convertedNum = convertedNum & "H"
                Case "9"
                    convertedNum = convertedNum & "I"
                Case "0"
                    convertedNum = convertedNum & "O"
                Case Else
                    convertedNum = convertedNum & currentChar
            End Select
        Next j
        
        resultArray(i) = convertedNum
    Next i
    
    ConvertNumbersToLetters = Join(resultArray, ", ")

End Function

Hopefully, you have found the solution you were looking for. I have attached the solution workbook as well; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Jon Peltier

Thanks for your invaluable feedback and suggestions! You are correct about the positive percentage error bars being inserted incorrectly. Based on your suggestions, we have updated the article section.

Regards
ExcelDemy

Hello Vickie

Thanks for visiting our blog and sharing an exciting problem with such clarity. I have reviewed your situation and developed two sub-procedures to fulfil your goal. Your problem is about automating email alerts in Excel based on conditional formatting for expiry dates of lifting equipment test certificates.

Don’t worry! I have demonstrated it in an Excel workbook. Please check the following:

Excel VBA Sub-procedure:

Sub SendEmailAlerts()

    Dim ws As Worksheet
    Dim cell As Range
    Dim expiryDate As Date
    Dim today As Date
    Dim emailBody As String
    Dim OutApp As Object
    Dim OutMail As Object

    Set ws = ThisWorkbook.Sheets("Sheet1")
    today = Date

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon

    For Each cell In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
        If IsDate(cell.Value) Then
            expiryDate = cell.Value
            If expiryDate <= today Then
                emailBody = "The test certificate for " & cell.Offset(0, -1).Value & " has expired on " & expiryDate & "."
                Call SendEmail(OutApp, emailBody, "Expiry Alert: Red")
            ElseIf expiryDate <= today + 30 Then
                emailBody = "The test certificate for " & cell.Offset(0, -1).Value & " will expire on " & expiryDate & "."
                Call SendEmail(OutApp, emailBody, "Expiry Alert: Yellow")
            End If
        End If
    Next cell

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Sub SendEmail(OutApp As Object, emailBody As String, subject As String)
    Dim OutMail As Object
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "[email protected]"
        .subject = subject
        .HTMLBody = "<p>" & emailBody & "</p>"
        .display
        '.Send 'To send emails, uncomment the ".Send" command.
    End With
End Sub

I hope you have found the sub-procedures you were looking for. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello David

Thanks for visiting our blog! For your address, the UTM Zone would be 32U. Let’s say your UTM Easting, UTM Northing, and UTM Zone are 691609.5, 5334764.67, and 32U. Using this UTM information, you can get the corresponding Latitude and Longitude. To achieve your goal, I have developed some Excel VBA User-defined functions.

Follow these steps:

1. Press Alt+F11 to open the VBA Editor.
2. Click on Insert followed by Module.
3. Paste the following code in the module and save it:

   Option Explicit
   
   Private Const WGS84_A As Double = 6378137#
   Private Const WGS84_E As Double = 0.081819190842622
   
   Function UTMToLatLong(Easting As Double, Northing As Double, Zone As String) As Variant
       
       Dim zoneNumber As Integer
       Dim zoneLetter As String
       Dim latitude As Double
       Dim longitude As Double
       Dim result(1 To 2) As Double
       
       zoneNumber = Val(Left(Zone, Len(Zone) - 1))
       zoneLetter = Right(Zone, 1)
       
       Call ConvertUTMToLatLon(Easting, Northing, zoneNumber, zoneLetter, latitude, longitude)
       
       result(1) = latitude
       result(2) = longitude
       
       UTMToLatLong = result
   
   End Function
   
   Sub ConvertUTMToLatLon(Easting As Double, Northing As Double, zoneNumber As Integer, zoneLetter As String, ByRef latitude As Double, ByRef longitude As Double)
       
       Dim k0 As Double
       k0 = 0.9996
       
       Dim E As Double, N As Double
       Dim A As Double, eccSquared As Double, eccPrimeSquared As Double
       Dim M As Double, mu As Double
       Dim e1 As Double, J1 As Double, J2 As Double, J3 As Double, J4 As Double, J5 As Double
       Dim FPhi1 As Double, C1 As Double, T1 As Double, R1 As Double, N1 As Double, D As Double
       
       E = Easting - 500000#
       If UCase(zoneLetter) < "N" Then
           N = Northing - 10000000#
       Else
           N = Northing
       End If
       
       A = WGS84_A
       eccSquared = WGS84_E ^ 2
       eccPrimeSquared = eccSquared / (1 - eccSquared)
       
       M = N / k0
       mu = M / (A * (1 - eccSquared / 4 - 3 * eccSquared ^ 2 / 64 - 5 * eccSquared ^ 3 / 256))
       
       e1 = (1 - Sqr(1 - eccSquared)) / (1 + Sqr(1 - eccSquared))
       
       J1 = 3 * e1 / 2 - 27 * e1 ^ 3 / 32
       J2 = 21 * e1 ^ 2 / 16 - 55 * e1 ^ 4 / 32
       J3 = 151 * e1 ^ 3 / 96
       J4 = 1097 * e1 ^ 4 / 512
       
       FPhi1 = mu + J1 * Sin(2 * mu) + J2 * Sin(4 * mu) + J3 * Sin(6 * mu) + J4 * Sin(8 * mu)
       
       C1 = eccPrimeSquared * Cos(FPhi1) ^ 2
       T1 = Tan(FPhi1) ^ 2
       R1 = A * (1 - eccSquared) / (1 - eccSquared * Sin(FPhi1) ^ 2) ^ 1.5
       N1 = A / Sqr(1 - eccSquared * Sin(FPhi1) ^ 2)
       D = E / (N1 * k0)
       
       latitude = FPhi1 - (N1 * Tan(FPhi1) / R1) * (D ^ 2 / 2 - (5 + 3 * T1 + 10 * C1 - 4 * C1 ^ 2 - 9 * eccPrimeSquared) * D ^ 4 / 24 + (61 + 90 * T1 + 298 * C1 + 45 * T1 ^ 2 - 252 * eccPrimeSquared - 3 * C1 ^ 2) * D ^ 6 / 720)
       latitude = latitude * 180 / Application.WorksheetFunction.Pi()
       
       longitude = (D - (1 + 2 * T1 + C1) * D ^ 3 / 6 + (5 - 2 * C1 + 28 * T1 - 3 * C1 ^ 2 + 8 * eccPrimeSquared + 24 * T1 ^ 2) * D ^ 5 / 120) / Cos(FPhi1)
       longitude = zoneNumber * 6 - 183 + longitude * 180 / Application.WorksheetFunction.Pi()
   
   End Sub

   

4. Return to the sheet and choose an empty cell.
5. Apply the following formula: =UTMToLatLong(B6, C6, D6)
6. Hit Enter.
   

Hopefully, these user-defined functions will help you reach your goal. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Jen

Thanks for explaining your requirements clearly. I have reviewed the existing user-defined function and tried to improve it to achieve your goal. The improved user-defined function will try to populate house numbers, roads, cities, states and zip codes by taking Lat and Long values; if any item is missing, it will display an extension like Incomplete!

Follow these steps:

1. Click on the Developer tab, followed by Visual Basic.
2. Next, click on Insert, followed by Module.
3. Paste the following code in the module and save it:

   Option Explicit
   
   Function ReverseGeocoder(lati As Double, longi As Double) As String
   
       On Error GoTo ErrorHandler
       Dim xD As New MSXML2.DOMDocument
       Dim URL As String
       Dim house As String
       Dim road As String
       Dim city As String
       Dim state As String
       Dim postcode As String
       
       xD.async = False
       URL = "https://nominatim.openstreetmap.org/reverse?lat=" + CStr(lati) + "&lon=" + CStr(longi)
       xD.Load (URL)
       
       If xD.parseError.ErrorCode <> 0 Then
           ReverseGeocoder = "Error: " & xD.parseError.reason
       Else
           xD.SetProperty "SelectionLanguage", "XPath"
           
           Dim houseNode As MSXML2.IXMLDOMElement
           Dim roadNode As MSXML2.IXMLDOMElement
           Dim cityNode As MSXML2.IXMLDOMElement
           Dim stateNode As MSXML2.IXMLDOMElement
           Dim postcodeNode As MSXML2.IXMLDOMElement
           
           Set houseNode = xD.SelectSingleNode("//addressparts/house_number")
           Set roadNode = xD.SelectSingleNode("//addressparts/road")
           Set cityNode = xD.SelectSingleNode("//addressparts/city")
           Set stateNode = xD.SelectSingleNode("//addressparts/state")
           Set postcodeNode = xD.SelectSingleNode("//addressparts/postcode")
           
           If Not houseNode Is Nothing Then
               house = houseNode.Text
           End If
           
           If Not roadNode Is Nothing Then
               road = roadNode.Text
           End If
           
           If Not cityNode Is Nothing Then
               city = cityNode.Text
           End If
           
           If Not stateNode Is Nothing Then
               state = stateNode.Text
           End If
           
           If Not postcodeNode Is Nothing Then
               postcode = postcodeNode.Text
           End If
           
           If house = "" Or road = "" Or city = "" Or state = "" Or postcode = "" Then
               ReverseGeocoder = house & " " & road & ", " & city & ", " & state & ", " & postcode & " [Incomplete!]"
           Else
               ReverseGeocoder = house & " " & road & ", " & city & ", " & state & ", " & postcode
           End If
       End If
       
       Exit Function
   
   ErrorHandler:
       ReverseGeocoder = "Error: " & Err.Description
       
   End Function

   

4. Return to the sheet and choose an empty cell.
5. Apply the following formula: =ReverseGeocoder(B5,C5)
6. Drag the Fill Handle icon to copy the formula down.
   

I hope you have found the user-defined function of reverse geocoding you were looking for. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Iona

Thanks for visiting our blog and sharing your requirements! I have reviewed your goal and created an Excel VBA Event procedure (assuming your dates are in column A).

Excel VBA Event Procedure:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cell As Range

    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        For Each cell In Target
            If cell.Value < (Date - 7) And cell.Interior.Color <> RGB(0, 255, 0) Then
                cell.Font.Color = RGB(255, 0, 0)
            ElseIf cell.Interior.Color = RGB(0, 255, 0) Then
                cell.Font.Color = RGB(0, 0, 0)
            End If
        Next cell
    End If
    
End Sub

Right-click on the sheet name tab, paste the given code into the sheet module and save it. Hopefully, the idea will fulfil your goal; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Abinsh

Thanks for sharing your requirements. You want to convert numbers to words in Qatar Riyal. Don’t worry! I have modified the previously given code to fulfil your goal.

Excel VBA User-Defined Function:

Function AdvancedWord(SNum As String)

    Dim zDPInt As Integer
    Dim zArrPlace As Variant
    Dim zRStr_Paisas As String
    Dim zNumStr As String
    Dim zP As Integer
    Dim zTemp As String
    Dim zStrTemp As String
    Dim zRStr As String
    Dim zBp As Integer

    zArrPlace = Array("", "", " Thousand ", " Lacs ", " Crores ", " Trillion ", "", "", "", "")

    On Error Resume Next

    If SNum = "" Then
        word = ""
        Exit Function
    End If

    zNumStr = Trim(Str(SNum))

    If zNumStr = "" Then
        word = ""
        Exit Function
    End If

    zRStr = ""
    zBp = 0

    If (zNumStr > 999999999.99) Then
        word = "Digit exceeds Maximum limit"
        Exit Function
    End If

    zDPInt = InStr(zNumStr, ".")

    If zDPInt > 0 Then
        If (Len(zNumStr) - zDPInt) = 1 Then
            zRStr_Paisas = word_GetT(Left(Mid(zNumStr, zDPInt + 1) & "0", 2))
        ElseIf (Len(zNumStr) - zDPInt) > 1 Then
            zRStr_Paisas = word_GetT(Left(Mid(zNumStr, zDPInt + 1), 2))
        End If
        zNumStr = Trim(Left(zNumStr, zDPInt - 1))
    End If

    zP = 1

    Do While zNumStr <> ""
        If (zP >= 2) Then
            zTemp = Right(zNumStr, 2)
        Else
            If (Len(zNumStr) = 2) Then
                zTemp = Right(zNumStr, 2)
            ElseIf (Len(zNumStr) = 1) Then
                zTemp = Right(zNumStr, 1)
            Else
                zTemp = Right(zNumStr, 3)
            End If
        End If

        zStrTemp = ""

        If Val(zTemp) > 99 Then
            zStrTemp = word_GetH(Right(zTemp, 3), zBp)
            If Right(Trim(zStrTemp), 3) <> "Lac" Then
                zBp = zBp + 1
            End If
        ElseIf Val(zTemp) <= 99 And Val(zTemp) > 9 Then
            zStrTemp = word_GetT(Right(zTemp, 2))
        ElseIf Val(zTemp) < 10 Then
            zStrTemp = word_GetD(Right(zTemp, 2))
        End If

        If zStrTemp <> "" Then
            zRStr = zStrTemp & zArrPlace(zP) & zRStr
        End If

        If zP = 2 Then
            If Len(zNumStr) = 1 Then
                zNumStr = ""
            Else
                zNumStr = Left(zNumStr, Len(zNumStr) - 2)
            End If
        ElseIf zP = 3 Then
            If Len(zNumStr) >= 3 Then
                zNumStr = Left(zNumStr, Len(zNumStr) - 2)
            Else
                zNumStr = ""
            End If
        ElseIf zP = 4 Then
            zNumStr = ""
        Else
            If Len(zNumStr) <= 2 Then
                zNumStr = ""
            Else
                zNumStr = Left(zNumStr, Len(zNumStr) - 3)
            End If
        End If

        zP = zP + 1
    Loop

    If zRStr = "" Then
        zRStr = "No Qatar Riyals"
    Else
        zRStr = " Qatar Riyals " & zRStr
    End If

    If zRStr_Paisas <> "" Then
        zRStr_Paisas = " and " & zRStr_Paisas & " Dirhams"
    End If

    AdvancedWord = zRStr & zRStr_Paisas & " Only"
End Function

Function word_GetH(zStrH As String, zBp As Integer)
    Dim zRStr As String

    If Val(zStrH) < 1 Then
        word_GetH = ""
        Exit Function
    Else
        zStrH = Right("000" & zStrH, 3)
        If Mid(zStrH, 1, 1) <> "0" Then
            If (zBp > 0) Then
                zRStr = word_GetD(Mid(zStrH, 1, 1)) & " Lac "
            Else
                zRStr = word_GetD(Mid(zStrH, 1, 1)) & " Hundred "
            End If
        End If

        If Mid(zStrH, 2, 1) <> "0" Then
            zRStr = zRStr & word_GetT(Mid(zStrH, 2))
        Else
            zRStr = zRStr & word_GetD(Mid(zStrH, 3))
        End If
    End If

    word_GetH = zRStr
End Function

Function word_GetT(zTStr As String)
    Dim zTArr1 As Variant
    Dim zTArr2 As Variant
    Dim zRStr As String

    zTArr1 = Array("Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
    zTArr2 = Array("", "Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
    Result = ""

    If Val(Left(zTStr, 1)) = 1 Then
        zRStr = zTArr1(Val(Mid(zTStr, 2, 1)))
    Else
        If Val(Left(zTStr, 1)) > 0 Then
            zRStr = zTArr2(Val(Left(zTStr, 1)) - 1)
        End If
        zRStr = zRStr & word_GetD(Right(zTStr, 1))
    End If

    word_GetT = zRStr
End Function

Function word_GetD(zDStr As String)
    Dim zArr_1() As Variant

    zArr_1 = Array(" One", " Two", " Three", " Four", " Five", " Six", " Seven", " Eight", " Nine", "")

    If Val(zDStr) > 0 Then
        word_GetD = zArr_1(Val(zDStr) - 1)
    Else
        word_GetD = ""
    End If
End Function

I hope you have found the solution you were looking for. I have attached the solution workbook. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards

Lutfor Rahman Shimanto

Excel & VBA Developer

ExcelDemy

Hello Fazlay Rabby

Thanks for your compliment! You are very welcome. We are glad that you found the article helpful.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hi Nat

Thanks for your patience and feedback. We apologize for any confusion. While the article covers two common reasons for date filter issues, other factors might be at play in your case.

You mentioned trying the two solutions and not getting the desired results. We recommend joining our ExcelDemy Forum. You can post your question there and attach your Excel file for a more detailed look.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Fulad

Thanks for your compliment! As you requested, you can use the following dataset, which contains data with your mentioned fields:

You can download the workbook from the following link:

DOWNLOAD WORKBOOK

I hope you have found the dataset you were looking for; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Alan Ang

Thanks for visiting our blog and asking an interesting question. You seek the language codes for Simplified Chinese, Traditional Chinese, and Central Khmer. Please check the following table:

Language	Language Code
English	en
Simplified Chinese	zh-CN
Traditional Chinese	zh-TW
Central Khmer	km

You can easily translate and fulfil your goal using the above language codes and the user-defined function mentioned in this article.

I hope you have found the language code you were looking for. I have attached the workbook used to investigate your question; good luck.

DOWNLOAD WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Dear Adam

Thanks for your feedback. I have reviewed your requirements. It seems like you want to perform a lookup of multiple entries (country names) in a single cell separated by a delimiter, such as commas. There will be a lookup table to keep the corresponding short names for each country. You are looking for a complex formula that takes multiple country names separated by commas, returns corresponding values (country short names), and displays them in a single cell.

Don’t worry! I have demonstrated your situation and developed a complex formula to fulfil your goal. I used the TEXTJOIN, INDEX, MATCH, TRIM, and TEXTSPLIT functions to build the formula.

SOLUTION Overview:

Suppose you want to enter the comma-separated country names in cell E1. In cell E2, you want to display country short names. To do so,

1. Select cell E2.
2. Insert the following formula: =TEXTJOIN(", ", TRUE, INDEX($A$2:$B$46, MATCH(TRIM(TEXTSPLIT($E$1, ",")), $A$2:$A$46, 0), 2 ))

I hope you have found the formula you were looking for. I have attached the solution workbook as well; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Anon

Thanks for your question! You wanted formulas to check for changes in multiple columns. Assuming you have three columns: First Name, Middle Name, and Last Name, you want to check for changes in the Timestamp column.

Solution Overview:

Follow these steps:

1. Select cell F5 and insert the following formula: =IF(B5="","",IF(OR(E5="",AND(ISNUMBER(F5),B5=F5)),F5,B5))
2. Press Enter and use the Fill Handle icon to copy the formula down.
3. Select cell G5 and apply the following formula: =IF(C5="","",IF(OR(E5="",AND(ISNUMBER(G5),C5=G5)),G5,C5))
4. Press Enter and use the Fill Handle icon to copy the formula down.
5. Select cell H5 and insert the following formula: =IF(D5="","",IF(OR(E5="",AND(ISNUMBER(H5),D5=H5)),H5,D5))
6. Press Enter and use the Fill Handle icon to copy the formula down.
7. Select cell E5 and insert the following formula: =IF(AND(B5<>"",F5<>B5, G5 <> C5, H5 <> D5),NOW(),IF(B5="","",E5))
8. Press Enter and use the Fill Handle icon to copy the formula down.

Now, input the intended names to see the output, like the GIF above.

I hope these are the formulas you were looking for. I have attached the solution workbook; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Steve Zimmermann

Thanks for visiting our blog and sharing your problem. You mentioned that the existing article methods work fine for regular Excel but not when opened inside SolidWorks (SW). Instead of showing the cell color, you get a #BLOCKED! Error; it shows up when a required resource can not be accessible.

It seems there are compatibility issues between VBA functionalities and SolidWorks. When Excel is opened by other applications like SolidWorks, some features and functionalities may not be available. As a result, when some resources are unavailable, they show #BLOCKED!

To overcome your situation, you can check the settings related to external scripting. You can also reach out to the SolidWorks community forum. Providing a solution without glancing at your file and being remote is very tough. I hope these ideas will help you; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Dear Peter Berger

Thanks for your feedback. Perhaps you are right about using the direct results from Nominatim, which would lead to more accurate outcomes. However, we have to get the result from the response from the Nominatim API.

In addition to your previous post, you wanted to get all the information in a column but in different cells. Do not worry! I have improved the previously given code by using a 2D array.

SOLUTION Overview:

Required Excel VBA User-Defined Functions:

Option Explicit

Function ReverseGeocoder(lati As Double, longi As Double) As Variant
    On Error GoTo 0
    
    Dim xD As New MSXML2.DOMDocument
    Dim URL As String, vbErr As String
    
    xD.async = False
    URL = "https://nominatim.openstreetmap.org/reverse?lat=" + CStr(lati) + _
            "&lon=" + CStr(longi)
    
    xD.Load ("https://nominatim.openstreetmap.org/reverse?lat=" + CStr(lati) + _
            "&lon=" + CStr(longi))
    
    If xD.parseError.ErrorCode <> 0 Then
        Application.Caller.Font.ColorIndex = vbErr
        ReverseGeocoder = xD.parseError.reason
    Else
        xD.SetProperty "SelectionLanguage", "XPath"
        Dim loca As MSXML2.IXMLDOMElement
        Set loca = xD.SelectSingleNode("/reversegeocode/result")
        
        If loca Is Nothing Then
            Application.Caller.Font.ColorIndex = vbErr
            ReverseGeocoder = xD.XML
        Else
            Application.Caller.Font.ColorIndex = vbOK
            ReverseGeocoder = SplitStringToArray(loca.Text)
        End If
    End If
    
    Exit Function
    
0:
    Debug.Print Err.Description
    
End Function

Function SplitStringToArray(strInput As String) As Variant
    
    Dim arrResult As Variant
    Dim i As Integer
    
    arrResult = Split(strInput, ", ")
    
    Dim numRows As Long
    numRows = UBound(arrResult) - LBound(arrResult) + 1
    
    Dim result() As Variant
    ReDim result(1 To numRows, 1 To 1)
    
    For i = LBound(arrResult) To UBound(arrResult)
        result(i + 1, 1) = arrResult(i)
    Next i
    
    SplitStringToArray = result

End Function

Hopefully, you have found the idea helpful. Download the solution workbook. Stay blessed.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello James Martin

Thanks for visiting our blog and sharing your problem. When working with this code in another workbook, you are facing “Compile error: User-defined type not defined“. This error typically occurs when the required library or reference is not activated in the VBA Editor.

Initial Problem:

To overcome the problem, you must refer to the Microsoft VBScript Regular Expressions 5.5 library in VBA Editor.

SOLUTION Overview:
Press Alt+F11 >> Tools >> References >> Microsoft VBScript Regular Expressions 5.5 >> OK.

I have improved the codes and solved your problem in a workbook. You can find these codes in the modules. Hopefully, you have found the solution helpful. I have attached the solution workbook as well; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Adele

Thanks for your nice words. We are glad you found the article helpful!

In Excel, we are directly unable to undo a VBA macro action in the same way you can undo regular actions using the Ctrl + Z shortcut. So, you must use the Excel Track Changes feature, or you can also use external version control systems like Git.

I hope these ideas will overcome your situation; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Vyshnav V S

It is good to see you again. When sending a reminder email, you want to add a user interface instead of running the Excel VBA Sub-procedure. To achieve this goal, you must use an Excel UserForm. I have designed a user interface in an Excel File.

SOLUTION Overview:

I hope the solution will help you reach your goal. I have also attached the solution workbook; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Greg

Thanks for visiting our blog and informing us that the previous solution worked perfectly. You want to filter the data that includes the date falling within the specified date range (0 to 14 days). Also, you want to include the rows where the document submittal date is blank.

I have come up with an Excel VBA code. You can try it; if needed, make changes to fulfil your goal.

SOLUTION Overview:

Excel VBA Code:

Sub SendEmails()

    Dim deadlineRange As Range
    Dim emailRange As Range
    Dim topicRange As Range
    Dim docSubmittalRange As Range
    Dim ws As Worksheet
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim i As Long
    
    On Error Resume Next
    Set deadlineRange = Application.InputBox("Select the range of deadlines:", Type:=8)
    On Error GoTo 0
    If deadlineRange Is Nothing Then Exit Sub
    
    On Error Resume Next
    Set emailRange = Application.InputBox("Select the range of emails:", Type:=8)
    On Error GoTo 0
    If emailRange Is Nothing Then Exit Sub
    
    On Error Resume Next
    Set topicRange = Application.InputBox("Select the range of topics:", Type:=8)
    On Error GoTo 0
    If topicRange Is Nothing Then Exit Sub
    
    On Error Resume Next
    Set docSubmittalRange = Application.InputBox("Select the range of document submittal dates:", Type:=8)
    On Error GoTo 0
    If docSubmittalRange Is Nothing Then Exit Sub
    
    Set ws = ThisWorkbook.ActiveSheet
    
    Set outlookApp = CreateObject("Outlook.Application")
    
    For i = 1 To emailRange.Rows.Count

        If deadlineRange.Cells(i, 1).Value >= Date And deadlineRange.Cells(i, 1).Value <= Date + 14 Then

            If Trim(docSubmittalRange.Cells(i, 1).Value) = "" Then
                Set outlookMail = outlookApp.CreateItem(0)
                
                With outlookMail
                    .To = emailRange.Cells(i, 1).Value
                    .Subject = topicRange.Cells(i, 1).Value & " " & Format(deadlineRange.Cells(i, 1).Value, "dd mmmm yyyy")
                    .Body = "Dear," & vbCrLf & vbCrLf & _
                            "TEXT: " & topicRange.Cells(i, 1).Value & vbCrLf & _
                            "DEADLINE: " & Format(deadlineRange.Cells(i, 1).Value, "dd mmmm yyyy") & "." & vbCrLf & vbCrLf & _
                            "Kind regards,"
                    .Display
                    On Error Resume Next
                    .Send
                End With
                
                Set outlookMail = Nothing
            End If
        End If
    Next i
    
    Set outlookApp = Nothing
    Set ws = Nothing
    Set topicRange = Nothing
    Set emailRange = Nothing
    Set deadlineRange = Nothing
    Set docSubmittalRange = Nothing

End Sub

I have attached the solution workbook; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Vyshnav V S

It is good to see you again. You want to upgrade the previously given VBA code to include a feature that retrieves task details from an ALM system or a similar work item system.

To do so, connect to the ALM or work item system to fetch task details within the VBA. Later, you can develop a function to find the task details based on the task ID from the Excel sheet and generate a link to the task’s details. The implementation will depend on the system used and its access methods (like APIs).

Hopefully, the idea will help you; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Dear Vyshnav V S

It is great to see you again. Thanks for reaching out and sharing another exciting problem.

To add a Request for Delivery Receipt and a Read Receipt in the Outlook Application, we must use the ReadReceiptRequested and OriginatorDeliveryReportRequested properties. Do not worry! Based on your new requirements, I have enhanced the existing sub-procedure (I provided earlier).

SOLUTION Overview:

Excel VBA SUb-procedure:

Sub SendReminderEmails()

    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("DATA")

    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).row

    For i = 5 To lastRow
        If ws.Cells(i, "C").Value < Date Then
            Set outlookApp = CreateObject("Outlook.Application")
            Set outlookMail = outlookApp.CreateItem(0)

            outlookMail.To = ws.Cells(i, "F").Value
            outlookMail.Subject = "Reminder: " & ws.Cells(i, "E").Value

            outlookMail.Body = "Dear " & vbCrLf & vbCrLf & _
                               "This is a reminder that Task ID " & ws.Cells(i, "D").Value & " is overdue." & vbCrLf & vbCrLf & _
                               ws.Cells(i, "E").Value & "," & vbCrLf & _
                               "Start Date: " & ws.Cells(i, "B").Value & vbCrLf & _
                               "Planned Due Date: " & Format(ws.Cells(i, "C").Value, "DD-MMM-YYYY") & vbCrLf & _
                               "Mail Content: " & ws.Cells(i, "F").Value & vbCrLf & _
                               "Reviewer: " & ws.Cells(i, "G").Value & vbCrLf & vbCrLf & _
                               "Please take necessary action." & vbCrLf & vbCrLf & _
                               "Regards," & vbCrLf & _
                               "Vyshnav V S"
            
            
            outlookMail.ReadReceiptRequested = True
            outlookMail.OriginatorDeliveryReportRequested = True

            outlookMail.Display

            On Error Resume Next
            outlookMail.Send

            Set outlookMail = Nothing
            Set outlookApp = Nothing
        End If
    
    Next i
    
End Sub

I hope you have found the solution you were looking for. The solution workbook is attached; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello MEDO

Thanks for letting us know that the solution works perfectly on your end. However, you want to handle cultural settings in VBA, which also works on non-UK clients.

Assuming your requirements are related to the decimal separator and thousand separator settings. Different regions worldwide use different conventions to represent decimals and thousands of separators.

You can use two user-defined functions to replace these separators with periods and commas to overcome the situation. I have developed two VBA user-defined functions and slightly changed the existing sub-procedures.

Calculating Distance in Miles:

Option Explicit

Public Function DistanceInMiles(First_Location As String, _
                                  Final_Location As String, _
                                  Target_Value As String) As Double

    Dim Initial_Point As String
    Dim Ending_Point As String
    Dim Distance_Unit As String
    Dim Setup_HTTP As Object
    Dim Output_Url As String

    Initial_Point = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins="
    Ending_Point = "&destinations="
    Distance_Unit = "&travelMode=driving&o=xml&key=" & Target_Value & "&distanceUnit=mi"

    Set Setup_HTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    First_Location = AddCommaInBetweenM(ReplaceCharsM(First_Location))
    Final_Location = AddCommaInBetweenM(ReplaceCharsM(Final_Location))
    
    Output_Url = Initial_Point & First_Location & Ending_Point & Final_Location & Distance_Unit

    Setup_HTTP.Open "GET", Output_Url, False
    Setup_HTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    Setup_HTTP.Send ("")

    Dim distance As Double
    distance = Round(Round(WorksheetFunction.FilterXML(Setup_HTTP.ResponseText, "//TravelDistance"), 3), 0)

    DistanceInMiles = Format(distance, "#,##0.00")

End Function

Function ReplaceCharsM(strInput As String) As String

    Dim i As Long
    Dim strOutput As String
    Dim char As String

    For i = 1 To Len(strInput)
        char = Mid(strInput, i, 1)
        Select Case char
            Case Application.International(xlDecimalSeparator)
                strOutput = strOutput & "."
            Case Application.International(xlThousandsSeparator)
                strOutput = strOutput & ","
            Case Else
                strOutput = strOutput & char
        End Select
    Next i

    ReplaceCharsM = strOutput

End Function

Function AddCommaInBetweenM(inputString As String) As String
    
    Dim resultString As String
    Dim i As Integer
    
    resultString = Left(inputString, 1)
    
    For i = 2 To Len(inputString)
        If Mid(inputString, i, 1) = " " Then
            resultString = Left(resultString, Len(resultString) - 1) & ","
        Else
            resultString = resultString & Mid(inputString, i, 1)
        End If
    Next i
    
    AddCommaInBetweenM = resultString
    
End Function

Calculating Distance in KM:

Option Explicit

Public Function DistanceInKM(First_Location As String, Final_Location As String, _
                             Target_Value As String) As String

    Dim Initial_Point As String
    Dim Ending_Point As String
    Dim Distance_Unit As String
    Dim Setup_HTTP As Object
    Dim Output_Url As String

    Initial_Point = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins="
    Ending_Point = "&destinations="
    Distance_Unit = "&travelMode=driving&o=xml&key=" & Target_Value & "&distanceUnit=km"

    Set Setup_HTTP = CreateObject("MSXML2.ServerXMLHTTP")

    First_Location = AddCommaInBetweenKM(ReplaceCharsKM(First_Location))
    Final_Location = AddCommaInBetweenKM(ReplaceCharsKM(Final_Location))

    Output_Url = Initial_Point & First_Location & Ending_Point & Final_Location & Distance_Unit

    Setup_HTTP.Open "GET", Output_Url, False
    Setup_HTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    Setup_HTTP.Send ("")

    DistanceInKM = Round(Round(WorksheetFunction.FilterXML(Setup_HTTP.ResponseText, _
                                                          "//TravelDistance"), 3), 0)

End Function

Function ReplaceCharsKM(strInput As String) As String

    Dim i As Long
    Dim strOutput As String
    Dim char As String

    For i = 1 To Len(strInput)
        char = Mid(strInput, i, 1)
        Select Case char
            Case Application.International(xlDecimalSeparator)
                strOutput = strOutput & "."
            Case Application.International(xlThousandsSeparator)
                strOutput = strOutput & ","
            Case Else
                strOutput = strOutput & char
        End Select
    Next i

    ReplaceCharsKM = strOutput

End Function

Function AddCommaInBetweenKM(inputString As String) As String
    
    Dim resultString As String
    Dim i As Integer
    
    resultString = Left(inputString, 1)
    
    For i = 2 To Len(inputString)
        If Mid(inputString, i, 1) = " " Then
            resultString = Left(resultString, Len(resultString) - 1) & ","
        Else
            resultString = resultString & Mid(inputString, i, 1)
        End If
    Next i
    
    AddCommaInBetweenKM = resultString
    
End Function

Hopefully, the VBA code will help you with your problem; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Isaac Chavez

Thanks for visiting our blog. As requested, I have developed an Excel VBA Sub-procedure that will send an Email notification if the Deadline is 7 days ahead.

SOLUTION Overview:

Note: If the Microsoft Outlook dialog box appears, click Allow to send an email.

Excel VBA Sub-procedure:

Sub SendNotificationEmails()

    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("DATA")
    
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).row
    
    For i = 5 To lastRow
        If ws.Cells(i, "C").Value - Date = 7 Then
            Set outlookApp = CreateObject("Outlook.Application")
            Set outlookMail = outlookApp.CreateItem(0)
            
            outlookMail.To = ws.Cells(i, "E").Value
            outlookMail.Subject = "Reminder: " & ws.Cells(i, "D").Value
            
            outlookMail.Body = "Dear " & vbCrLf & vbCrLf & _
                                ws.Cells(i, "E").Value & "," & vbCrLf & _
                               "Start Date: " & ws.Cells(i, "B").Value & vbCrLf & _
                               "Deadline: " & Format(ws.Cells(i, "C").Value, "DD-MMM-YYYY") & vbCrLf & _
                               "Mail Content: " & ws.Cells(i, "D").Value & vbCrLf & _
                               "Please take necessary action." & vbCrLf & vbCrLf & _
                               "Regards," & vbCrLf & _
                               "Isaac Chavez"
            
            outlookMail.Display
            
            On Error Resume Next
            outlookMail.Send
            
            Set outlookMail = Nothing
            Set outlookApp = Nothing
        End If
    Next i

End Sub

I hope the sub-procedure will fulfil your requirements. I have attached the solution workbook as well; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear Vyshnav V S

Thanks for clarifying your requirements further. I have modified the previously given code to fulfil your goal. Now, you can select any column containing email IDs, and all the other required information will be retrieved from columns C and D.

SOLUTION Overview:

Excel VBA Sub-procedure:

Sub SendEmailUsingSelectedRows()

    Dim selectedRange As Range
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim row As Range
    
    For Each row In Selection.Rows
        
        If Not IsEmpty(row.Cells(1, 1).Value) Then

            Set outlookApp = CreateObject("Outlook.Application")
            Set outlookMail = outlookApp.CreateItem(0)

            outlookMail.To = row.Cells(1, 1).Value
            outlookMail.Subject = "Your ExcelDemy Registration Information"

            outlookMail.Body = "Greetings," & vbCrLf & vbCrLf & _
                                Range("D" & row.row).Value & vbCrLf & vbCrLf & _
                                "Deadline: " & Range("E" & row.row).Value & vbCrLf & vbCrLf & _
                                "ExcelDemy Team"
            On Error Resume Next
            outlookMail.Display
            outlookMail.Send

            Set outlookMail = Nothing
            Set outlookApp = Nothing
        
        End If
    Next row

End Sub

Make changes to the code if necessary. I hope the code will fulfil your goal; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Vyshnav V S

Thanks for visiting our blog and sharing an exciting problem. I have developed an Excel VBA Sub-procedure that meets both requirements.

To send email using VBA, you can use the Send property. When sending an email, the Microsoft Outlook dialog box will appear. Lastly, you must click on Allow to send email.

SOLUTION Overview:

1. Enabling Multi-row Selection:
   
2. Send Emails by Selecting a Row (specifically the email ID column in that row):
   

NOTE: Additionally, the sub-procedure will validate your selection. If you select another column instead of the ID column (assuming it is column B), the message will pop up saying to choose the intended column.

Excel VBA Sub-procedure:

Sub SendEmailUsingSelectedRows()

    Dim selectedRange As Range
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim row As Range
    
    If Selection.Column <> 2 Then
        MsgBox "Please select a range of cells in the Email ID column (Column B).", vbCritical
        Exit Sub
    End If
    
    For Each row In Selection.Rows

        If Not IsEmpty(row.Cells(1, 1).Value) Then

            Set outlookApp = CreateObject("Outlook.Application")
            Set outlookMail = outlookApp.CreateItem(0)

            outlookMail.To = row.Cells(1, 1).Value
            outlookMail.Subject = "Your ExcelDemy Registration Information"

            outlookMail.Body = "Greetings," & vbCrLf & vbCrLf & _
                                row.Cells(1, 2).Value & vbCrLf & vbCrLf & _
                                "Deadline: " & row.Cells(1, 3).Value & vbCrLf & vbCrLf & _
                                "ExcelDemy Team"
            On Error Resume Next
            outlookMail.Display
            outlookMail.Send

            Set outlookMail = Nothing
            Set outlookApp = Nothing
        
        End If
    Next row

End Sub

Hopefully, the sub-procedure will meet your expectations. I have attached the solution workbook as well. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Isaac Chavez

Thanks for visiting our blog and sharing your problem. I have developed an Excel VBA Sub-procedure that automatically sends emails.

SOLUTION Overview:

All you need to do is to click on Allow when the Microsoft Outlook dialog box appears.

Excel VBA Sub-procedure:

Sub SendEmails()

    Dim deadlineRange As Range
    Dim emailRange As Range
    Dim topicRange As Range
    Dim ws As Worksheet
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim i As Long
    
    On Error Resume Next
    Set deadlineRange = Application.InputBox("Select the range of deadlines:", Type:=8)
    On Error GoTo 0
    If deadlineRange Is Nothing Then Exit Sub
    
    On Error Resume Next
    Set emailRange = Application.InputBox("Select the range of emails:", Type:=8)
    On Error GoTo 0
    If emailRange Is Nothing Then Exit Sub
    
    On Error Resume Next
    Set topicRange = Application.InputBox("Select the range of topics:", Type:=8)
    On Error GoTo 0
    If topicRange Is Nothing Then Exit Sub
    
    Set ws = ThisWorkbook.ActiveSheet
    
    Set outlookApp = CreateObject("Outlook.Application")
    
    For i = 1 To emailRange.Rows.Count

        Set outlookMail = outlookApp.CreateItem(0)
        
        With outlookMail
            .To = emailRange.Cells(i, 1).Value
            .Subject = topicRange.Cells(i, 1).Value & " " & Format(deadlineRange.Cells(i, 1).Value, "dd mmmm yyyy")
            .Body = "Dear," & vbCrLf & vbCrLf & _
                    "TEXT: " & topicRange.Cells(i, 1).Value & vbCrLf & _
                    "DEADLINE: " & Format(deadlineRange.Cells(i, 1).Value, "dd mmmm yyyy") & "." & vbCrLf & vbCrLf & _
                    "Kind regards,"
            .Display
            .Send
        End With
        
        Set outlookMail = Nothing
    Next i
    
    Set outlookApp = Nothing
    Set ws = Nothing
    Set topicRange = Nothing
    Set emailRange = Nothing
    Set deadlineRange = Nothing

End Sub

When testing the sub-procedure, I accidentally emailed you by pressing Allow in the Microsoft Outlook dialog box. Please ignore that. I hope the sub-procedure will fulfil your goal; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Bharti

Thanks for visiting our blog and posting an exciting comment. As requested, I have developed an Excel VBA User-defined function to get Meteorological Week no.

Standard Meteorological Weeks:

Follow these steps:

1. Press Alt+F11.
2. Click on Insert followed by Module.
3. Paste the following code into the module and save it:

   Function GETMeteorologicalWeekNo(inputDate As Date) As Long
       
       Dim dict As Object
       Set dict = CreateObject("Scripting.Dictionary")
   
       dict.Add 1, "01 Jan – 07 Jan"
       dict.Add 2, "08 Jan – 14 Jan"
       dict.Add 3, "15 Jan – 21 Jan"
       dict.Add 4, "22 Jan – 28 Jan"
       dict.Add 5, "29 Jan – 04 Feb"
       dict.Add 6, "05 Feb – 11 Feb"
       dict.Add 7, "12 Feb – 18 Feb"
       dict.Add 8, "19 Feb – 25 Feb"
       dict.Add 9, "26 Feb – 04 Mar"
       dict.Add 10, "05 Mar – 11 Mar"
       dict.Add 11, "12 Mar – 18 Mar"
       dict.Add 12, "19 Mar – 25 Mar"
       dict.Add 13, "26 Mar – 01 Apr"
       dict.Add 14, "02 Apr – 08 Apr"
       dict.Add 15, "09 Apr – 15 Apr"
       dict.Add 16, "16 Apr – 22 Apr"
       dict.Add 17, "23 Apr – 29 Apr"
       dict.Add 18, "30 Apr – 06 May"
       dict.Add 19, "07 May – 13 May"
       dict.Add 20, "14 May – 20 May"
       dict.Add 21, "21 May – 27 May"
       dict.Add 22, "28 May – 03 Jun"
       dict.Add 23, "04 Jun – 10 Jun"
       dict.Add 24, "11 Jun – 17 Jun"
       dict.Add 25, "18 Jun – 24 Jun"
       dict.Add 26, "25 Jun – 01 Jul"
       dict.Add 27, "02 Jul – 08 Jul"
       dict.Add 28, "09 Jul – 15 Jul"
       dict.Add 29, "16 Jul – 22 Jul"
       dict.Add 30, "23 Jul – 29 Jul"
       dict.Add 31, "30 Jul – 05 Aug"
       dict.Add 32, "06 Aug – 12 Aug"
       dict.Add 33, "13 Aug – 19 Aug"
       dict.Add 34, "20 Aug – 26 Aug"
       dict.Add 35, "27 Aug – 02 Sep"
       dict.Add 36, "03 Sep – 09 Sep"
       dict.Add 37, "10 Sep – 16 Sep"
       dict.Add 38, "17 Sep – 23 Sep"
       dict.Add 39, "24 Sep – 30 Sep"
       dict.Add 40, "01 Oct – 07 Oct"
       dict.Add 41, "08 Oct – 14 Oct"
       dict.Add 42, "15 Oct – 21 Oct"
       dict.Add 43, "22 Oct – 28 Oct"
       dict.Add 44, "29 Oct – 04 Nov"
       dict.Add 45, "05 Nov – 11 Nov"
       dict.Add 46, "12 Nov – 18 Nov"
       dict.Add 47, "19 Nov – 25 Nov"
       dict.Add 48, "26 Nov – 02 Dec"
       dict.Add 49, "03 Dec – 09 Dec"
       dict.Add 50, "10 Dec – 16 Dec"
       dict.Add 51, "17 Dec – 23 Dec"
       dict.Add 52, "24 Dec – 31 Dec"
       
       Dim yearValue As Integer
       Dim startDate As Date
       Dim endDate As Date
       
       yearValue = year(inputDate)
       
       Dim key As Variant
       For Each key In dict.Keys
           Dim dates() As String
           dates = Split(dict(key), "–")
           startDate = DateValue(Trim(dates(0)) & " " & yearValue)
           endDate = DateValue(Trim(dates(1)) & " " & yearValue)
           
           If inputDate >= startDate And inputDate <= endDate Then
               GETMeteorologicalWeekNo = key
               Exit Function
           End If
       Next key
   
       GETMeteorologicalWeekNo = 0
       
   End Function

   

4. Return to the sheet and select cell B2.
5. Insert the following formula: =GETMeteorologicalWeekNo(A2)
6. Drap the Fill Handle icon to copy the formula down.
   

I hope the Excel VBA User-defined function will fulfil your goal. I also have attached the solution workbook; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Andre Van Niekerk

Thanks for sharing your problem. It is unusual for copying and pasting to stop working entirely in Excel 2013 if it worked perfectly in Excel 2010. Both versions rely on the same core Windows clipboard functionality.

The PDF file copied from might have a complex layout or structure that Excel 2013 has difficulty handling during the copy-and-paste process. Also, if you’re trying to paste into merged cells in Excel 2013, it might cause problems. Try un-merging the cells before pasting.

If you are still having trouble with the issue, we recommend you use the other approaches mentioned. Let us know if they lead you to the same result; good luck.

Regards
ExcelDemy

Hello Marvin

Thanks for visiting our blog and sharing your questions so clearly. Basically, you want to have a timestamp for each row and store it in two different columns: one for the Date Entered and the other for the Date Modified.

SOLUTION Overview:

I have developed an Excel VBA Event Procedure regarding your problem:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range

    Set rng = Me.Range("C2:C" & Me.Rows.Count)

    If Not Intersect(Target, rng) Is Nothing Then
        Application.EnableEvents = False

        For Each cell In Intersect(Target, rng)
            
            If Not IsEmpty(cell) Then

                If IsEmpty(cell.Offset(0, -2)) Then
                    cell.Offset(0, -2).Value = Format(Now, "dd-mm-yyy hh:mm:ss")
                End If
                cell.Offset(0, -1).Value = Format(Now, "dd-mm-yyy hh:mm:ss")
                
            Else
                cell.Offset(0, -2).ClearContents
                cell.Offset(0, -1).Value = Format(Now, "dd-mm-yyy hh:mm:ss")
            End If
            
        Next cell

        Application.EnableEvents = True
    
    End If

End Sub

Hopefully, you have found the idea. I have attached the solution workbook for better understanding; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Bonnie

Thanks for reaching out. Though a few steps are needed, making mistakes along the way is obvious. But no worries! The ExcelDemy Forum is there to help. Just share your workbook and ask for advice.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Tracey

Thanks for your nice words. Your appreciation means a lot to us.

Creating a Leave Tracker in Excel requires multiple steps, so you may often get unintentional errors when following these steps. Do not worry! You can share your problem within the ExcelDemy Forum by attaching your workbook.

Regards
ExcelDemy

Hello Denise Sano

Thanks for visiting our blog and leaving an exciting comment. You want to rank salespeople by region based on number of units sold and then (in the case of ties) by total sales amount. However, developing such a formula using Excel’s built-in function would be time-consuming.

So, I have developed an Excel VBA sub-procedure to help you overcome your situation.

Follow these steps:

1. Press Alt+F11.
2. Click on Insert followed by Module.
3. Paste the following code into the Module and run it:

   Sub RankSalesRepByRegion()
   
       Dim ws As Worksheet
       Dim lastRow As Long
       Dim salesRepCol As Range, regionCol As Range, unitsSoldCol As Range, salesAmountCol As Range, rankCol As Range
       Dim region As Range, uniqueRegions As New Collection
       Dim i As Long
       
       Set ws = ThisWorkbook.Sheets("Sheet1")
       
       lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
       
       Set salesRepCol = ws.Range("A2:A" & lastRow)
       Set regionCol = ws.Range("B2:B" & lastRow)
       Set unitsSoldCol = ws.Range("C2:C" & lastRow)
       Set salesAmountCol = ws.Range("D2:D" & lastRow)
       Set rankCol = ws.Range("E2:E" & lastRow)
       
       For Each region In regionCol
           On Error Resume Next
           uniqueRegions.Add region.Value, CStr(region.Value)
           On Error GoTo 0
       Next region
       
       For i = 1 To uniqueRegions.Count
           Dim regionName As String
           regionName = uniqueRegions(i)
           
           Dim salesReps() As String
           Dim unitsSold() As Long
           Dim salesAmount() As Double
           Dim ranks() As Integer
           
           Dim j As Long
           Dim uniqueCount As Long
           uniqueCount = 0
           
           For j = 1 To lastRow - 1
               If regionCol.Cells(j, 1).Value = regionName Then
                   uniqueCount = uniqueCount + 1
                   ReDim Preserve salesReps(1 To uniqueCount)
                   ReDim Preserve unitsSold(1 To uniqueCount)
                   ReDim Preserve salesAmount(1 To uniqueCount)
                   
                   salesReps(uniqueCount) = salesRepCol.Cells(j, 1).Value
                   unitsSold(uniqueCount) = unitsSoldCol.Cells(j, 1).Value
                   salesAmount(uniqueCount) = salesAmountCol.Cells(j, 1).Value
               End If
           Next j
           
           For j = 1 To uniqueCount - 1
               For k = j + 1 To uniqueCount
                   If unitsSold(j) < unitsSold(k) Or (unitsSold(j) = unitsSold(k) And salesAmount(j) < salesAmount(k)) Then
   
                       Dim tempSalesRep As String
                       tempSalesRep = salesReps(j)
                       salesReps(j) = salesReps(k)
                       salesReps(k) = tempSalesRep
                       
                       Dim tempUnitsSold As Long
                       tempUnitsSold = unitsSold(j)
                       unitsSold(j) = unitsSold(k)
                       unitsSold(k) = tempUnitsSold
                       
                       Dim tempSalesAmount As Double
                       tempSalesAmount = salesAmount(j)
                       salesAmount(j) = salesAmount(k)
                       salesAmount(k) = tempSalesAmount
                   End If
               Next k
           Next j
           
           ReDim ranks(1 To uniqueCount)
           ranks(1) = 1
           For j = 2 To uniqueCount
               If unitsSold(j - 1) = unitsSold(j) And salesAmount(j - 1) = salesAmount(j) Then
                   ranks(j) = ranks(j - 1)
               Else
                   ranks(j) = j
               End If
           Next j
           
           For j = 1 To uniqueCount
               For k = 1 To lastRow
                   If salesRepCol.Cells(k, 1).Value = salesReps(j) Then
                       rankCol.Cells(k, 1).Value = ranks(j)
                       Exit For
                   End If
               Next k
           Next j
       Next i
   
   End Sub

   

As a result, you get the intended rank like the following GIF.

I have attached the solution workbook for better understanding. Hopefully, the idea will help; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards

Lutfor Rahman Shimanto

Excel & VBA Developer

ExcelDemy

Dear Brent Hamilton

Thanks for visiting our blog. You’re right; the article was described based on an older version of MS 365, likely pre-dating March 2024.

From now on, in Excel 365, the Track Changes functionality has been integrated into the Show Changes button. It is important to note that saving the file to OneDrive is a prerequisite for using this feature.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello JAN ZAKOS TELSKY,

I hope you are doing well. Thank u so much for your query. Well, I can see you want to add the ID number (Column A)  in the mail body when the changing row falls below the value from the corresponding cell. You also added that the changing values are in column H, and the static value is in column I.

Now, follow the below VBA code to write the ID number from column A in the email body when the value in column H falls below the value of column I.

Code:

Sub SendEmailOnValueChange()

Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim OutlookApp As Object

Set OutlookApp = CreateObject("Outlook.Application")

Dim MItem As Object

Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your actual sheet name

lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row

For i = 2 To lastRow
If ws.Cells(i, "H").Value < ws.Cells(i, "I").Value Then
Set OutlookApp = CreateObject("Outlook.Application")
Set MItem = OutlookApp.CreateItem(0)

With MItem
.To = "[email protected]" ' Change to your recipient email address
.subject = "Value in column H has fallen below value in column I"
.body = "The value in row " & i & " of column H has fallen below the corresponding value in column I." & vbCrLf & _
"ID number from column A: " & ws.Cells(i, "A").Value
.Send
End With

Set MItem = Nothing
Set OutlookApp = Nothing

End If

Next i

End Sub

Once you apply the code, you will get an email as below.

Hope this information will help you. Please let us know if there is any further query in the comment section.

Best Regards,
Afrina Nafisa 
Exceldemy

Hello Nirmani

Thanks for reaching out and sharing your problem. You passed an argument that could not be manipulated into the type expected; the ByRef error happens. For example, when you try to supply an Integer variable when a Long is required.

If you encounter a ByRef error related to your database variable, it could be due to how you pass the worksheet object reference. Ensure that the data types of the database variable matches the expected data type in the subroutine.

When the UserForm_Activate event triggers, pass the correct worksheet reference. Double-check that the worksheet name you’re passing matches the actual name of the worksheet in your Excel file.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Vipin

Thanks for your nice words. Your appreciation means a lot to us.

You are facing an issue with a worksheet with a Doughnut chart and a textbox in its center to display a value from another cell. The textbox is visible on the desktop version of Excel but not on the online version.

You have tried moving the textbox to the front using Bring to Front, but it doesn’t work. You have also tried sending the chart to the back using Send to Back, but it doesn’t help either.

The issue might be browser-specific. Different web browsers sometimes display online applications differently. For example, I do not have this type of issue at all.

You may be using an older Excel Online version with this bug. Microsoft frequently updates Excel Online, and they might have fixed the issue in newer versions. Check if there are any updates available.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello CHANDRA

Thanks for visiting our blog and posting an exciting comment. You want to convert decimal numbers (up to two decimal places) to words in Rupees.

To do so, follow these:

1. Right-click on the sheet name tab.
2. Click on View Code.
3. Now, please insert the following code in the sheet module and save it:

   Function AdvancedWord(SNum As String)
   
       Dim zDPInt As Integer
       Dim zArrPlace As Variant
       Dim zRStr_Paisas As String
       Dim zNumStr As String
       Dim zP As Integer
       Dim zTemp As String
       Dim zStrTemp As String
       Dim zRStr As String
       Dim zBp As Integer
       
       zArrPlace = Array("", "", " Thousand ", " Lacs ", " Crores ", " Trillion ", "", "", "", "")
       
       On Error Resume Next
       
       If SNum = "" Then
           word = ""
           Exit Function
       End If
       
       zNumStr = Trim(Str(SNum))
       
       If zNumStr = "" Then
           word = ""
           Exit Function
       End If
       
       zRStr = ""
       zBp = 0
       
       If (zNumStr > 999999999.99) Then
           word = "Digit exceeds Maximum limit"
           Exit Function
       End If
       
       zDPInt = InStr(zNumStr, ".")
       
       If zDPInt > 0 Then
           If (Len(zNumStr) - zDPInt) = 1 Then
               zRStr_Paisas = word_GetT(Left(Mid(zNumStr, zDPInt + 1) & "0", 2))
           ElseIf (Len(zNumStr) - zDPInt) > 1 Then
               zRStr_Paisas = word_GetT(Left(Mid(zNumStr, zDPInt + 1), 2))
           End If
           zNumStr = Trim(Left(zNumStr, zDPInt - 1))
       End If
       
       zP = 1
       
       Do While zNumStr <> ""
           If (zP >= 2) Then
               zTemp = Right(zNumStr, 2)
           Else
               If (Len(zNumStr) = 2) Then
                   zTemp = Right(zNumStr, 2)
               ElseIf (Len(zNumStr) = 1) Then
                   zTemp = Right(zNumStr, 1)
               Else
                   zTemp = Right(zNumStr, 3)
               End If
           End If
           
           zStrTemp = ""
           
           If Val(zTemp) > 99 Then
               zStrTemp = word_GetH(Right(zTemp, 3), zBp)
               If Right(Trim(zStrTemp), 3) <> "Lac" Then
                   zBp = zBp + 1
               End If
           ElseIf Val(zTemp) <= 99 And Val(zTemp) > 9 Then
               zStrTemp = word_GetT(Right(zTemp, 2))
           ElseIf Val(zTemp) < 10 Then
               zStrTemp = word_GetD(Right(zTemp, 2))
           End If
           
           If zStrTemp <> "" Then
               zRStr = zStrTemp & zArrPlace(zP) & zRStr
           End If
           
           If zP = 2 Then
               If Len(zNumStr) = 1 Then
                   zNumStr = ""
               Else
                   zNumStr = Left(zNumStr, Len(zNumStr) - 2)
               End If
           ElseIf zP = 3 Then
               If Len(zNumStr) >= 3 Then
                   zNumStr = Left(zNumStr, Len(zNumStr) - 2)
               Else
                   zNumStr = ""
               End If
           ElseIf zP = 4 Then
               zNumStr = ""
           Else
               If Len(zNumStr) <= 2 Then
                   zNumStr = ""
               Else
                   zNumStr = Left(zNumStr, Len(zNumStr) - 3)
               End If
           End If
           
           zP = zP + 1
       Loop
       
       If zRStr = "" Then
           zRStr = "No Rupees"
       Else
           zRStr = " Rupees " & zRStr
       End If
       
       If zRStr_Paisas <> "" Then
           zRStr_Paisas = " and " & zRStr_Paisas & " Paisas"
       End If
       
       AdvancedWord = zRStr & zRStr_Paisas & " Only"
   End Function
   
   Function word_GetH(zStrH As String, zBp As Integer)
       Dim zRStr As String
       
       If Val(zStrH) < 1 Then
           word_GetH = ""
           Exit Function
       Else
           zStrH = Right("000" & zStrH, 3)
           If Mid(zStrH, 1, 1) <> "0" Then
               If (zBp > 0) Then
                   zRStr = word_GetD(Mid(zStrH, 1, 1)) & " Lac "
               Else
                   zRStr = word_GetD(Mid(zStrH, 1, 1)) & " Hundred "
               End If
           End If
           
           If Mid(zStrH, 2, 1) <> "0" Then
               zRStr = zRStr & word_GetT(Mid(zStrH, 2))
           Else
               zRStr = zRStr & word_GetD(Mid(zStrH, 3))
           End If
       End If
       
       word_GetH = zRStr
   End Function
   
   Function word_GetT(zTStr As String)
       Dim zTArr1 As Variant
       Dim zTArr2 As Variant
       Dim zRStr As String
       
       zTArr1 = Array("Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
       zTArr2 = Array("", "Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
       Result = ""
       
       If Val(Left(zTStr, 1)) = 1 Then
           zRStr = zTArr1(Val(Mid(zTStr, 2, 1)))
       Else
           If Val(Left(zTStr, 1)) > 0 Then
               zRStr = zTArr2(Val(Left(zTStr, 1)) - 1)
           End If
           zRStr = zRStr & word_GetD(Right(zTStr, 1))
       End If
       
       word_GetT = zRStr
   End Function
   
   Function word_GetD(zDStr As String)
       Dim zArr_1() As Variant
       
       zArr_1 = Array(" One", " Two", " Three", " Four", " Five", " Six", " Seven", " Eight", " Nine", "")
       
       If Val(zDStr) > 0 Then
           word_GetD = zArr_1(Val(zDStr) - 1)
       Else
           word_GetD = ""
       End If
   End Function

   

4. Return to the sheet and select the intended cell.
5. Apply the following formula: =AdvancedWord(B5)
6. Drag the Fill Handle icon to copy the formula down.
   

I am also attaching the solution workbook for better understanding. I hope the solution will help you; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards

Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Peter Clarke

Thanks for reaching out and sharing your problems and suggestions. You put a Public Variable to display in all procedures but got an “out of scope” report. You want a thorough explanation.

This issue could arise due to several reasons:

• Proper Declaration: Ensure the Public Variable is declared correctly at the module level, typically at the top of a module and outside any specific procedure.
• Module Inclusion: Check that the module containing the Public Variable is included in the project. If it’s not included or there are visibility issues, the variable may not be accessible across all procedures.
• Reference Check: If multiple modules or projects exist, ensure no conflicts or reference issues. Public Variables should be accessible across all referenced projects and modules.

I have demonstrated watching a Public Variable in the Watch Window. I am using three modules: one for the public variable, one for displaying the public variable, and one for watching the public variable.

VBA Code in Module1:

Public totalSales As Long

VBA Code in Module2:

Public Sub DisplayTotalSales()
    Debug.Print totalSales
End Sub

VBA Code in Module3:

Sub CalculateTotalSales()
    
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim productA As Variant
    Dim productB As Variant
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    For i = 6 To lastRow
        
        If IsNumeric(ws.Cells(i, 3).Value) Then
            productA = ws.Cells(i, 3).Value
        Else
            productA = 0
        End If
        
        If IsNumeric(ws.Cells(i, 4).Value) Then
            productB = ws.Cells(i, 4).Value
        Else
            productB = 0
        End If
        
        totalSales = productA + productB
        ws.Cells(i, 5).Value = totalSales
        
        Call DisplayTotalSales
    
    Next i

End Sub

OUTPUT Overview:

Hopefully, the idea will overcome your situation. Good luck.

Regards

Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Dear VICTORI,

Thanks for your feedback. It seems that you have mistakenly assumed that we didn’t include the 5.50% growth rate in our calculations.

The growth rate is used for calculating the stream of future payments. As we showed this calculation in method 1 (i.e. Using the NPV Function method), we didn’t show it again in method 2 and suggested users to see it from the previous method.

However, as it has dodged your eyes, we have included the detailed calculation in method 2 as well. You also suggested that the FV formula we provided, is for a regular annuity, not a growing annuity. This is true, and we have updated our article according to your feedback. You can check the updated article and share your feedback with us.

Thank you again for your valuable comment.

Regards,
Seemanto Saha
Team ExcelDemy

Hello JULI

Thanks for visiting our blog and sharing your query. You can modify the formula mentioned in example 1.4 and find the last cell with a number value on another sheet: =LOOKUP(2,1/(Week_1!C:C),ROW(Week_1!C:C))

I hope the formula will overcome your issue; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Hardik

Thanks for visiting our blog and sharing your difficulties. To find the total cost of the products sold that cost more than $1,000 using cell value as Criteria:

1. Select cell L9.
2. Insert the following formula: =SUMIF(G6:G92, K9, G6:G92)
3. Hit Enter to see the following output.
   

Hopefully, the formula will overcome the situation; good luck.

Regards

Lutfor Rahman Shimanto

ExcelDemy

Dear KEITH BASKETT,

Thanks for sharing your problem with us. I understand that you are using InputBox to take the number of rows you wish to fill in a column and then repeat the process for the next columns. However, you are facing errors when you enter a text or invalid input or press the OK, Cancel, or X button without entering any value.

To fix these errors, you have to include a few error-handling situations in your code. Here, I have provided a sample code that contains error handling for your described situations:

Sub HandleErrorsWhileFillingRows()
    Dim response As Variant
    Dim runAgain As Boolean
    Dim repeatCol As Variant
    Dim numRows As Variant
    Dim curCol As Integer
   
    runAgain = True
    curCol = 1
   
    While runAgain
        numRows = InputBox("Enter the number of rows:", "Number of Rows", 20)
        If Not numRows = "" Then
            If IsNumeric(numRows) Then
                For i = 1 To Int(numRows)
                    Cells(i, curCol).Value = i
                Next i
                repeatCol = vbNo
            Else
                MsgBox "The input was not a number"
                repeatCol = MsgBox("Do you want to repeat this column?", vbYesNo, "Repeat Column?")
            End If
        Else
            MsgBox "You entered a blank value"
            repeatCol = MsgBox("Do you want to repeat this column?", vbYesNo, "Repeat Column?")
        End If
       
        If repeatCol = vbYes Then
            runAgain = True
        Else
            response = MsgBox("Do you want to enter numbers in next column?", vbYesNo, "Enter Number in Next Column")
            If response = vbYes Then
                curCol = curCol + 1
                runAgain = True
            Else
                runAgain = False
                MsgBox "You finished filling rows"
            End If
        End If
    Wend
   
End Sub

Here’s how this code operates:

• >> This code starts with the current column value of 1 (column A) and asks users to enter the number of rows they wish to fill with numbers. The value is set to 20 by default, but the users can change it to any number or text or keep it void.
• >> If the user input is numeric, then it enters values in cells of the current column (from 1 to the number of specified rows).
• >> If the user input is non-numeric, then it shows the message “The input was not a number” and asks if the user wishes to repeat filling the current column again.
• >> If the user clicks Yes, the previous steps are repeated for the current column. Otherwise, the code moves to the next column.
• >> If a user clicks OK with a void input or clicks Cancel or X buttons, then it shows the message “You entered a blank value” and asks if the user wishes to repeat filling the current column again.
• >> If the user clicks Yes, the previous steps are repeated for the current column. Otherwise, the code moves to the next column.

You can preview the output in the following GIF:

I hope this example will be helpful for you to understand how to handle errors while working with an InputBox in Excel VBA. Let us know your feedback.

Regards,

Seemanto Saha

Team ExcelDemy

Hello ALAN

Thank you for reaching out. Please ensure that you’re using a 64-bit Windows system. Let us know if the issue persists.

You can share your dataset by creating a Conversation with my forum account in the ExcelDemy Forum.

Best regards
Lutfor Rahman Shimanto
ExcelDemy

Dear NADEE

Thanks for sharing your problem with us. I understand that you want to extract the Julian date from a string and convert the Julian date to the Gregorian Date.

This can be accomplished using a simple formula. To demonstrate an example, I have taken the following dataset. Here, column A contains the employee names, and column B contains the string code with Julian dates. In column C, I have applied the following formula to extract the Julian Date:

=MID(B2,LEN(A2)+1,7)

Afterward, I applied the following formula to convert the Julian date to the Gregorian date:

=DATE(LEFT(C2,4),1,0)+MOD(C2,1000)

Thus, you can easily convert a Julian date to a Gregorian date. I hope this solution will be helpful for your requirements. Let us know your feedback.

Regards

Seemanto Saha

Team ExcelDemy

Hello SHIVAM

Thanks for your comment. To create a shift scheduler for a 5-member team with the specified shifts and off days, you can follow these steps:

1. Create a table or spreadsheet with columns for the days of the week (Monday to Sunday) and rows for each team member.
2. Assign each team member to a specific shift (Morning, Evening, Night, General) based on availability and preferences.
3. Apply the off days for each member according to the given schedule (e.g., Member 1 off on Friday and Saturday).
4. Ensure that Member 5 is assigned to the General shift and occasionally to the Morning shift when required.
5. Repeat this process for each week or month, depending on the duration of your scheduling period.

Here is an example of how you could structure the scheduler:

Hopefully, the idea will help you; good luck.

Regards

Lutfor Rahman Shimanto
ExcelDemy

Hello SHIQIANG

Thanks for sharing your problem. Typically, we are unable to perform such tasks in Excel. However, you can try using an Excel VBA Sub-procedure I have developed. It will display all the color indexes of the selected cells in the Immediate Window. The idea works perfectly if background is set manually or only one conditional formatting rule is applied in a cell. You can easily modify the formula for multiple conditional formatting rules based on your needs.

OUTPUT Overview:

Excel VBA Code:

Sub GetConditionalFormattingColor()

    Dim cell As Range
    Dim colorIndex As Variant

    For Each cell In Selection
        If cell.FormatConditions.Count > 0 And cell.Value <> "" Then
            colorIndex = cell.FormatConditions(1).Interior.colorIndex
            Debug.Print "Background color index for cell " & cell.Address & ": " & colorIndex
        Else
            colorIndex = cell.Interior.colorIndex
            
            If colorIndex = -4142 Then
                Debug.Print "Currently, the Cell " & cell.Address & " does not have any color."
            Else
                Debug.Print "Background color index for cell " & cell.Address & ": " & colorIndex
            End If

        End If
    Next cell
    
End Sub

Reach out again if you have any further queries. Hopefully, the idea will help you; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello KARAN

Thanks for reaching out and posting such an interesting comment. Yes, you can manually specify holidays using the NETWORKDAYS.INTL function to customize which days are considered weekends and also lets you include specific holidays.

In your case, the first and second arguments in the formula are for the start and end dates; you can use 11 3rd arguments to consider only Sunday as the weekend. In the 4th argument, you insert the specified holiday.

=NETWORKDAYS.INTL(startDate, endDate, weekend, holidays)

I have developed a formula for January by focusing on your specified weekends and holidays.

=NETWORKDAYS.INTL(B2, B3, 11, A6:A7)

Hopefully, the formula will help; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hi ANDREW G,

Thank you very much for reading our articles.

You wanted to know a way to run the macro periodically without opening any file that will auto-refresh all the Excel files in a certain folder.

Here, I will discuss a way to fulfill your requirements. But to run a macro you need to open an Excel file and insert a macro in it. After that, the macro will refresh all your files in the mentioned folder. We will use the Task Scheduler feature of Windows to run the macro periodically.

1. First, insert the following macro in an Excel file named Refresh. The macro will be inserted into the workbook.
2. Then, save and close the macro and workbook.
3. The first part of the macro is a workbook event that will run whenever the workbook opens.

   Private Sub Workbook_Open()
   
       ThisWorkbook.Application.Visible = False
   
       Call AutoRefreshFolder
   
       ThisWorkbook.Application.Visible = True
   
       ThisWorkbook.Close
   
       Application.Quit
   
   End Sub
   
   Public Sub AutoRefreshFolder()
   
   Dim mrf As Object
   
   Dim mfolder As Object
   
   Dim mfile As Object
   
       mPath = "C:\Users\Alok Paul\Desktop\Softeko\Auto Refresh Excel File Without Opening\"
   
   Set mrf = CreateObject("Scripting.FileSystemObject")
   
   Set mfolder = mrf.GetFolder(mPath)
   
    With Application
   
           .DisplayAlerts = False
   
           .ScreenUpdating = False
   
           .EnableEvents = False
   
           .AskToUpdateLinks = False
   
    End With
   
    For Each mfile In mfolder.Files
   
       If Right(mfile.Name, 4) = "xlsx" Or Right(mfile.Name, 3) = "xls" Then
   
               Workbooks.Open mPath & mfile.Name
   
               ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
   
               ActiveWorkbook.Close True
   
       End If
   
    Next
   
    With Application
   
           .DisplayAlerts = True
   
           .ScreenUpdating = True
   
           .EnableEvents = True
   
           .AskToUpdateLinks = True
   
    End With
   
   End Sub

   

4. Type Task Scheduler in the Search box.
5. Then click on the Open option of the application.
   
6. In the Task Scheduler window, click the Create Task option from the Actions section.
   
7. In the Create Task window, go to the General tab.
8. Then, insert the name of the task in the Name box.
   
9. Next, go to the Triggers tab and click on New.
   
10. In the New Trigger window, mark Daily in the Settings section.
11. Next in the Advanced settings section, mark Repeat task every and choose 5 minutes. You can any other time.
12. Finally, press OK.
    
13. Then, click on the New option in the Actions tab.
    
14. The New Action window appears.
    
15. Insert the path of the Excel application in the program/script section and the path of the Excel file containing the macro.
16. Finally, press OK.
    
17. After that close the Task Scheduler and the macro will run every 5 minutes to refresh the Excel files inside the mentioned folder.

Best Regards,
Alok Paul
Team ExcelDemy

Hi Manisha

It is working fine for me and returning 10:16. Please give us more details about the formula and/or the dataset you are using.

Regards
Niloy
ExcelDemy

Hi ED,

Thank you for your query. Unfortunately, directly importing your Yahoo Finance watchlist into Excel for stock details retrieval is not feasible due to technical limitations.

Reason:

Yahoo Finance watchlists are dynamic web pages primarily rendered by JavaScript, while Excel’s Data > From Web feature captures static HTML snapshots. This fundamental difference prevents Excel from capturing the interactive and user-specific nature of watchlists.

As an alternative solution, I recommend downloading the template from this link. Add your company names from the watchlist to this template. This template facilitates tracking and decision-making for your listed stocks within Excel.

We trust that this solution aligns with your interests and needs.

Best regards,

Ishrak Khan

ExcelDemy

Hi DINESH,

Thanks for your comment. You can use the VBA code given below for the desired output.

1. Copy the following VBA code and paste it into the Module window:

   Public Function FormatCurrencyText(ByVal inputNumber As String) As String
       Dim decimalPosition As Integer
       Dim placeArray As Variant
       Dim paisaText As String
       Dim numText As String
       Dim index As Integer
       Dim tempText As String
       Dim strTemp As String
       Dim resultText As String
       Dim loopCounter As Integer
   
       ' Change these values according to your requirements
       placeArray = Array("", "", " Thousand ", " Lacs ", " Crores ", " Trillion ", "", "", "", "")
   
       On Error Resume Next
       If inputNumber = "" Then
           FormatCurrencyText = ""
           Exit Function
       End If
   
       numText = Trim(Str(inputNumber))
       If numText = "" Then
           FormatCurrencyText = ""
           Exit Function
       End If
   
       resultText = ""
       loopCounter = 0
   
       If (numText > 999999999.99) Then
           FormatCurrencyText = "Digit exceeds the maximum limit"
           Exit Function
       End If
   
       decimalPosition = InStr(numText, ".")
   
       If decimalPosition > 0 Then
           If (Len(numText) - decimalPosition) = 1 Then
               paisaText = CurrencyText_GetT(Left(Mid(numText, decimalPosition + 1) & "0", 2))
           ElseIf (Len(numText) - decimalPosition) > 1 Then
               paisaText = CurrencyText_GetT(Left(Mid(numText, decimalPosition + 1), 2))
           End If
   
           numText = Trim(Left(numText, decimalPosition - 1))
       End If
   
       index = 1
   
       Do While numText <> ""
           If (index >= 2) Then
               tempText = Right(numText, 2)
           Else
               If (Len(numText) = 2) Then
                   tempText = Right(numText, 2)
               ElseIf (Len(numText) = 1) Then
                   tempText = Right(numText, 1)
               Else
                   tempText = Right(numText, 3)
               End If
           End If
   
           strTemp = ""
           If Val(tempText) > 99 Then
               strTemp = CurrencyText_GetH(Right(tempText, 3), loopCounter)
               If Right(Trim(strTemp), 3) <> "Lac" Then
                   loopCounter = loopCounter + 1
               End If
           ElseIf Val(tempText) <= 99 And Val(tempText) > 9 Then
               strTemp = CurrencyText_GetT(Right(tempText, 2))
           ElseIf Val(tempText) < 10 Then
               strTemp = CurrencyText_GetD(Right(tempText, 2))
           End If
   
           If strTemp <> "" Then
               resultText = strTemp & placeArray(index) & resultText
           End If
   
           If index = 2 Then
               If Len(numText) = 1 Then
                   numText = ""
               Else
                   numText = Left(numText, Len(numText) - 2)
               End If
           ElseIf index = 3 Then
               If Len(numText) >= 3 Then
                   numText = Left(numText, Len(numText) - 2)
               Else
                   numText = ""
               End If
           ElseIf index = 4 Then
               numText = ""
           Else
               If Len(numText) <= 2 Then
                   numText = ""
               Else
                   numText = Left(numText, Len(numText) - 3)
               End If
           End If
   
           index = index + 1
       Loop
   
       If resultText = "" Then
           resultText = "No Rupees"
       End If
   
       If paisaText <> "" Then
           paisaText = " and " & paisaText & " Paise"
       End If
   
       FormatCurrencyText = resultText & paisaText
   End Function
   
   Function CurrencyText_GetH(ByVal inputStrH As String, ByVal loopCounter As Integer) As String
       Dim resultText As String
   
       If Val(inputStrH) < 1 Then
           CurrencyText_GetH = ""
           Exit Function
       Else
           inputStrH = Right("000" & inputStrH, 3)
   
           If Mid(inputStrH, 1, 1) <> "0" Then
               If (loopCounter > 0) Then
                   resultText = CurrencyText_GetD(Mid(inputStrH, 1, 1)) & " Lac "
               Else
                   resultText = CurrencyText_GetD(Mid(inputStrH, 1, 1)) & " Hundred "
               End If
           End If
   
           If Mid(inputStrH, 2, 1) <> "0" Then
               resultText = resultText & CurrencyText_GetT(Mid(inputStrH, 2))
           Else
               resultText = resultText & CurrencyText_GetD(Mid(inputStrH, 3))
           End If
       End If
   
       CurrencyText_GetH = resultText
   End Function
   
   Function CurrencyText_GetT(ByVal inputTStr As String) As String
       Dim arrT1 As Variant
       Dim arrT2 As Variant
       Dim resultText As String
   
       arrT1 = Array("Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
       arrT2 = Array("", "Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
   
       resultText = ""
   
       If Val(Left(inputTStr, 1)) = 1 Then
           resultText = arrT1(Val(Mid(inputTStr, 2, 1)))
       Else
           If Val(Left(inputTStr, 1)) > 0 Then
               resultText = arrT2(Val(Left(inputTStr, 1)) - 1)
           End If
   
           resultText = resultText & CurrencyText_GetD(Right(inputTStr, 1))
       End If
   
       CurrencyText_GetT = resultText
   End Function
   
   Function CurrencyText_GetD(ByVal inputDStr As String) As String
       Dim arr_1() As Variant
   
       arr_1 = Array(" One", " Two", " Three", " Four", " Five", " Six", " Seven", " Eight", " Nine", "")
   
       If Val(inputDStr) > 0 Then
           CurrencyText_GetD = arr_1(Val(inputDStr) - 1)
       Else
           CurrencyText_GetD = ""
       End If
   End Function

2. Press Ctrl+S to save the code.
3. Now, insert the formula in a cell and press Enter:
   =ConvertNumberToWords(Number)
   Or,
   =ConvertNumberToWords(Number containing cell reference)
   Like,
   =ConvertNumberToWords(54362543)
   Or,
   =ConvertNumberToWords(A1)

I hope this user-defined function will solve your problem. Please let us know in the comment section if you have any other queries.

Regards

Maruf Hasan

ExcelDemy

Hello OLIVER,

I hope you are doing well. Thank u for your query. Well, you can use the below formula to extract only the minimum value in the same cell.

=MIN(IFERROR(VALUE(MID($B$4:$B$8, FIND(":", $B$4:$B$8) + 1, LEN($B$4:$B$8))), ""))

Note: Change the range (B4:B8) according to your dataset.

Hope this information will help you. Please let us know if there is any further query in the comment section.

Best Regards,

Afrina Nafisa 

Exceldemy

Hi Chua!

It brings me great joy to know that you found our advice helpful. You are most welcome. As for troubleshooting your problem, it would be best if you could provide us with the Excel file. However, you could use the following steps to try to solve your problem on your own.

1. Go to your workbook. Right-click on the sheet tab where you are performing your calculation and select View Code.
2. Inside the code writing space, write the following code:

   Private Sub Worksheet_Change(ByVal Target As Range)
   
       Call ForcedReCalculation
   
   End Sub
   
   Sub ForcedReCalculation()
   
       Application.CalculateFull
   
   End Sub

3. Save your workbook (as .xlsm format)
4. Rerun your calculation.

If your problem is not yet solved, please join our ExcelDemy Forum and post this problem with your Excel file attached to it.

Regards,

Nafis

ExcelDemy

Dear DORABABU

Thank you for your comment and your insightful observation. You are correct in pointing out that making prepayments towards the principal amount of a home loan can indeed result in a reduction in the total number of EMIs. This is an important consideration and can have a significant impact on the overall loan repayment timeline.

To incorporate this feature into the home loan EMI calculator, you can make the following adjustments to the existing formula:

Update Total Number of Months (N):

Instead of fixing the total number of months as G4×12, you can dynamically adjust it based on the prepayments made. You can introduce a new variable, say M, representing the total number of months after considering prepayments. The formula for M would be: M=G4×12−Number of Prepayment Months

Modify the PMT Function for EMI Calculation:

Update the formula for EMI calculation (in cell C7) to reflect the adjusted total number of months (M): =ABS(PMT(E4/12,M,F7))

By making these changes, the calculator will dynamically adjust the total number of EMIs based on the prepayments made, providing you with a more accurate representation of the impact of principal payments on the loan tenure.

I hope this addresses your query. If you have any further questions or if there’s anything else you’d like to discuss, please feel free to ask.

Best Regards

Sumaiya Mirza

ExcelDemy

Hello Miriam,

Thank you for sharing your problem with us. We are sorry you’re experiencing issues with the Excel VBA script for getting cell color.

Here are a few steps you can take to address the problem:

1. First, to get your desired results, ensure you’re using Microsoft 365. Activate it on your PC to use the given methods for obtaining color indexes.
2. Then, follow the below steps to Check Macro Security Settings:
   • Make sure that your Excel settings allow the execution of macros. Go to File > Options > Trust Center > Trust Center Settings > Macro Settings and ensure that “Enable all macros” or “Enable all macros with notification” is selected.

Please let us know if your problem is solved or not.

Regards,
Bishawajit Chakraborty
ExcelDemy

Hello HANS ENGELS,

Thanks for your query. To extract data from the website to Excel automatically when the website requires login credentials, you must apply web scrapping techniques and automation tools.

First, you need to understand the web structure of that website and then use web scraping tools to get access to that website and extract data based on your needs.

Regards
MD Naimul Hasan
ExcelDemy

Dear NORTH80,

Thank you very much for reading our articles.
You have mentioned that, when pulling historical dividend information you faced a problem. The problem is:
“Expression.Error: The column ‘Dividends’ of the table wasn’t found.
Details:
Dividends”

Here is the modified query code to solve the mentioned problem.

let
    Ticker = Excel.CurrentWorkbook(){[Name="Ticker"]}[Content]{0}[Column1],
    StartDate = Excel.CurrentWorkbook(){[Name="StartDate"]}[Content]{0}[Column1],
    EndDate = Excel.CurrentWorkbook(){[Name="EndDate"]}[Content]{0}[Column1],
    Source = Csv.Document(Web.Contents("https://query1.finance.yahoo.com/v7/finance/download/"&Ticker&"?period1"&StartDate&"&period2"&EndDate&"&interval=1d&events=div&includeAdjustedClose=true"),[Delimiter=",", Columns=2, Encoding=65001, QuoteStyle=QuoteStyle.None]),
    #"Use First Row as Headers" = Table.PromoteHeaders(Source, [PromoteAllScalars=true]),
    #"Change Type" = Table.TransformColumnTypes(#"Use First Row as Headers",{{"Date", type date}, {"Dividends", type number}})
in
    #"Change Type"

If you face further problems, please write in the comment box.

Best Regards,
Alok Paul
Team ExcelDemy

Hi Zafar Iqbal,

In response to your request for some data entry work files, we have sent a PDF file for you to practice. Kindly check your email. You can also download the practice file provided with the article. Stay connected with ExcelDemy.

Regards
Rafiul Hasan
ExcelDemy

Hello LAKSHMI,

I hope you are doing well. Thank you for your query. You can combine sheets row-wise using the VBA code provided in the first method of this article. (Merge Data Sets from Multiple Sheets into One Sheet with VBA Row-wise). Once you go through this method of merging data sets, you will know where to change the code as the details are written in the “Note”.

Best Regards,
Afrina Nafisa
Exceldemy

Hello ODMA

Thanks for reaching out and sharing your queries. The previous question by ABIGAYLE PAULSON was to automate the idea that the filtering algorithm will be applied if the drop-down list in Sheet8 is changed. After analyzing your requirements, I understand that you do not want to use the filter algorithm if the drop-down is empty.

I have developed an Excel VBA Worksheet_Change Event that will fulfil your goal. All you need is to paste the following code in the sheet module of Sheet8 (the sheet that contains the drop-down).

Excel VBA Event Procedure:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim category As Range
    Dim dropdownCell As Range
    Dim ws7 As Worksheet
    Dim ws8 As Worksheet
    
    Set ws7 = Worksheets("Sheet7")
    Set ws8 = Worksheets("Sheet8")
    
    Set dropdownCell = ws8.Range("C2")
    
    If Not Intersect(Target, dropdownCell) Is Nothing Then

        If dropdownCell.Value = "" Then
            ws7.AutoFilterMode = False
        Else
            Set category = dropdownCell
            With ws7.Range("B4:G13")
                .AutoFilter Field:=2, Criteria1:=category.Value
            End With
        End If
    End If

End Sub

OUTPUT Overview:

Hopefully, the event procedure will help; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello ANDREW

Yes, that’s correct. In both methods described in the article, you would need to open the file containing the macro to auto-refresh the target Excel files. However, once the macro is executed, it will open and refresh the specified Excel files without manually opening them individually.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello RAMI

Thanks for visiting our blog and sharing your queries. You want to create multiple stopwatches in a sheet. Of course, the requirement is very much achievable.

I have displayed four stopwatches in the B4, F4, B15, and F15 cells.

OUTPUT OVERVIEW:

Follow these steps:

Press Alt+F11 >> Click on Insert followed by Module >> Insert the following code in the module >> Save.

Option Explicit

Public countDown1 As Date
Public countDown2 As Date
Public countDown3 As Date
Public countDown4 As Date

'For Stopwatch 1:
Sub StartTimer1()
    countDown1 = Now + TimeValue("00:00:01")
    Range("B4") = Range("B4") + TimeValue("00:00:01")
    Application.OnTime countDown1, "StartTimer1"
End Sub
Sub ResetTimer1()
    Range("B4") = TimeValue("00:00:0")
End Sub
Sub StopTimer1()
    Application.OnTime EarliestTime:=countDown1, Procedure:="StartTimer1", Schedule:=False
End Sub

'For Stopwatch 2:
Sub StartTimer2()
    countDown2 = Now + TimeValue("00:00:01")
    Range("F4") = Range("F4") + TimeValue("00:00:01")
    Application.OnTime countDown2, "StartTimer2"
End Sub
Sub ResetTimer2()
    Range("F4") = TimeValue("00:00:0")
End Sub
Sub StopTimer2()
    Application.OnTime EarliestTime:=countDown2, Procedure:="StartTimer2", Schedule:=False
End Sub

'For Stopwatch 3:
Sub StartTimer3()
    countDown3 = Now + TimeValue("00:00:01")
    Range("B15") = Range("B15") + TimeValue("00:00:01")
    Application.OnTime countDown3, "StartTimer3"
End Sub
Sub ResetTimer3()
    Range("B15") = TimeValue("00:00:0")
End Sub
Sub StopTimer3()
    Application.OnTime EarliestTime:=countDown3, Procedure:="StartTimer3", Schedule:=False
End Sub


'For Stopwatch 4:
Sub StartTimer4()
    countDown4 = Now + TimeValue("00:00:01")
    Range("F15") = Range("F15") + TimeValue("00:00:01")
    Application.OnTime countDown4, "StartTimer4"
End Sub
Sub ResetTimer4()
    Range("F15") = TimeValue("00:00:0")
End Sub
Sub StopTimer4()
    Application.OnTime EarliestTime:=countDown4, Procedure:="StartTimer4", Schedule:=False
End Sub

I hope you have learned how to create multiple stopwatches in a sheet. I am also attaching the solution workbook for better understanding; good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello DORY

Thanks a Ton! for your nice words. Your appreciation means a lot to us.

You would like to copy only a specific range from the source workbook. I am presenting an Excel VBA Sub-procedure that will fulfil your requirements.

OUTPUT OVERVIEW:

Excel VBA Sub-procedure:

Sub CopySheets()
    
    Dim Source As String
    Dim Destination As Workbook
    
    Source = "C:\Users\PC 50\Downloads\SOURCE.xlsx"
    Set Destination = ThisWorkbook
    
    Dim Worksheets As Variant
    ReDim Worksheets(3)
    
    Worksheets(1) = "Sheet1"
    Worksheets(2) = "Sheet2"
    Worksheets(3) = "Sheet3"
    
    Dim i As Variant
    Dim rng As Range
    
    For i = 1 To UBound(Worksheets)
        Set rng = Workbooks.Open(Source).Sheets(Worksheets(i)).Range("A1:D11")
        rng.Copy Destination:=Destination.Sheets(Worksheets(i)).Range("A1")
    Next i
    
End Sub

Hopefully, you will like the example and the sub-procedure. Good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello BRYAN

Thanks for visiting our blog. All the methods described in the article are working perfectly on our end. It is important to remember the intended effect you want to see when you have printed the sheet.

OUTPUT OVERVIEW:

So, I recommend you reread the article; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Dear Kelly

Thank you so much for your kind words! It’s fantastic to hear that our tutorial has been helpful to you. You’ve already made quite an impact in your new role, becoming the Excel expert in your office – that’s quite an accomplishment!

Let us know if you ever need more help with Excel or anything else. We’re here for you. Best wishes for your continued success at the mom & pop shop!

Best Regards
Lutfor Rahman Shimanto
ExcelDemy Team

Hi Karthick

Thank you for reaching out with your inquiry! Designing a shift schedule for a 4-member team roster with diverse shift patterns can be challenging.

Each shift, A, B, C, and D, has a schedule for weekdays, weekends, and special arrangements on Wednesdays. Setting these parameters upfront allows you to assign team members to their shifts more efficiently.

On Wednesdays, all four members are active but in different roles. It would be best if you had a flexible framework to handle this. One idea is to create a dynamic formula that adjusts shift assignments based on the day of the week and specific requirements. This might involve using conditional logic to distribute team members across day and night shifts, ensuring we have enough coverage while using resources effectively.

Don’t forget to explore the resources in the article, including the practice workbook, to gain hands-on experience with building and refining your shift scheduler. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello FRED FUTCH

Thanks for sharing your problem. You might be experiencing some formatting issues in Excel when inputting numbers.

Ensure that the cells where you are typing numbers are formatted as General or Number. Sometimes, Excel may automatically apply a different format if it detects a specific pattern in the data.

Sometimes, Excel’s behaviour can be influenced by the regional settings on your computer. Make sure that your computer’s regional settings are configured correctly.

Hopefully, the idea will help in your situation; good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Samir

Thanks for visiting our blog and posting an interesting comment. You want to convert a number (e.g., 10245) into a string where each digit of the number is represented by its word form (e.g., “One Zero Two Four Five”).

I am delighted to inform you that I have developed an Excel VBA User-defined function named NumberToString to fulfil your goal. I am using the function in a Sub-procedure. However, you can also use it in Excel cells like other worksheet functions.

OUTPUT OVERVIEW:

Excel VBA Code:

Function NumberToString(ByVal num As String) As String
    
    Dim result As String
    Dim i As Integer
    Dim digit As String
    
    Dim digits() As String
    digits = Split("Zero,One,Two,Three,Four,Five,Six,Seven,Eight,Nine", ",")
    
    For i = 1 To Len(num)
        digit = Mid(num, i, 1)
        result = result & digits(Val(digit)) & " "
    Next i
    
    NumberToString = Trim(result)

End Function

Sub TestNumberToWords()
    
    Dim num As Long
    num = 146897
    Debug.Print NumberToString(CStr(num))

End Sub

Hopefully, the user-defined function will help you reach your goal; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello JAN ZÁKOSTELSKÝ

Thanks for reaching out and sharing your problem. You want to compare two Excel rows: one that remains constant and another that changes. You need to receive an email whenever a number in any cell of the changing row becomes lower than the value in the corresponding cell of the constant row.

I am delighted to inform you that I have developed an Excel VBA Sub-procedure and an Event Procedure. These will fulfil your requirements.

Follow these steps:

1. Right-click on the sheet name tab.

2. Click on View Code.

3. Insert the following code in the sheet module and Save.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim staticRow As Range
    Dim changingRow As Range
    Dim cellStatic As Range
    Dim cellChanging As Range
    Dim emailSubject As String
    Dim emailBody As String
    Dim emailTo As String
    
    Set staticRow = Range("A2:D3")
    Set changingRow = Range("A3:D3")
    
    emailTo = "[email protected]"
    
    If Not Intersect(Target, changingRow) Is Nothing Then

        For Each cellChanging In Intersect(Target, changingRow)
            Set cellStatic = staticRow.Cells(cellChanging.Column - changingRow.Column + 1)

            If IsNumeric(cellStatic.Value) And IsNumeric(cellChanging.Value) Then
                If cellChanging.Value < cellStatic.Value Then
                    emailSubject = "Value Below Threshold"
                    emailBody = "The value in cell " & cellChanging.Address & " is below the threshold (" & cellStatic.Value & ")."
                    SendEmail emailTo, emailSubject, emailBody
                    Exit Sub
                End If
            End If
        Next cellChanging
    End If
End Sub

Sub SendEmail(emailTo As String, subject As String, body As String)

    Dim outlookApp As Object
    Dim emailItem As Object
    
    Set outlookApp = CreateObject("Outlook.Application")
    Set emailItem = outlookApp.CreateItem(0)
    
    With emailItem
        .To = emailTo
        .subject = subject
        .body = body
        .Display
    End With
    
    Set emailItem = Nothing
    Set outlookApp = Nothing

End Sub

4. Return to the sheet and make changes to see an output like the following GIF.

Hopefully, the idea will help you; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello ANUPAM

Thanks for reaching out and sharing your queries. You not only want to count total links but also to display cells containing links.

I am delighted to inform you that I have an Excel VBA sub-procedure that will fulfil your goal. The code will display the total links in a MsgBox and show all the cells containing links in the Immediate window.

OUTPUT OVERVIEW:

Excel VBA Sub-procedure:

Sub CountAndListLinks()
    Dim wb As Workbook
    Dim linkCount As Integer
    Dim linkCell As Range
    
    Set wb = Application.ActiveWorkbook
    linkCount = 0
    
    If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
        For Each linkCell In wb.Sheets(1).UsedRange.SpecialCells(xlCellTypeFormulas)
            If InStr(1, linkCell.Formula, "[") > 0 Then
                linkCount = linkCount + 1
                Debug.Print "Cell " & linkCell.Address & " contains a link."
            End If
        Next linkCell
        MsgBox "Total links found: " & linkCount
    Else
        MsgBox "No links found."
    End If
End Sub

Hopefully, the code will help you; good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello EXCELFLASH

Thanks a ton for taking the time to dive into our article and sharing your thoughts! We’re thrilled to hear that you found it excellent overall – that means a lot to us.

We’re sorry you encountered an issue with the formula from method 1. After investigating, we discovered that you are correct about the line spacing and quotation marks issues in that formula when copying.

We’ve updated the article, so feel free to retry it. Hopefully, this time around, you won’t encounter the same hassle with the formula. Let us know if you have any further questions or suggestions.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello TIM

Thanks for reaching out and sharing your query. You want an Excel VBA code that works perfectly for multiple columns and rows of checkboxes. I am presenting an enhanced VBA sub-procedure that may help you.

OUTPUT OVERVIEW:

Enhanced Excel VBA Code:

Sub AlignCheckbox()
    
    Dim xRg As Range
    Dim chkBox As OLEObject
    Dim chkFBox As CheckBox
    Dim cell As Range
    Dim cellWidth As Double
    Dim cellHeight As Double
    
    On Error Resume Next
    Application.ScreenUpdating = False
    
    For Each chkBox In ActiveSheet.OLEObjects
        If TypeName(chkBox.Object) = "CheckBox" Then
            Set xRg = chkBox.TopLeftCell
            With xRg
                cellWidth = .Width
                cellHeight = .Height
                chkBox.Width = cellWidth * 2 / 3
                chkBox.Left = .Left + (cellWidth - chkBox.Width) / 2
                chkBox.Top = .Top + (cellHeight - chkBox.Height) / 2
            End With
        End If
    Next
    
    For Each chkFBox In ActiveSheet.CheckBoxes
        Set xRg = chkFBox.TopLeftCell
        With xRg
            cellWidth = .Width
            cellHeight = .Height
            chkFBox.Width = cellWidth * 2 / 3
            chkFBox.Height = cellHeight
            chkFBox.Left = .Left + (cellWidth - chkFBox.Width) / 2
            chkFBox.Top = .Top + (cellHeight - chkFBox.Height) / 2
        End With
    Next
    
    Application.ScreenUpdating = True

End Sub

Hopefully, the sub-procedure will reduce your hassle. Good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Abdul

Thanks for reaching out and posting your comment. You want to highlight the scenario where a student, Raju, fails in one subject out of five but still manages to achieve a high percentage overall due to scoring well in the remaining subjects.

Basically, you want to ensure that Raju isn’t labelled a failure just because he fails one subject. In your view, Raju’s overall performance across all subjects should involve when determining his pass/fail status, not just the grade in one subject.

In this case, you use the following formula: =IF(COUNTIF(C5:G5, "<33")=0, "Pass", IF(AVERAGE(C5:G5)>=60, "Pass", "Fail"))

Here, the passing threshold for individuals is 33 and the average is 60.

Hopefully, you have found the idea helpful. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello SCOTT

Thanks a lot for your kind words. You want to specify a particular column from a table in Excel VBA ComboBox’s RowSource property.

Output Overview:

Let’s assume you have a table named Data in the sheet Database with several columns, and you want to populate your ComboBox with the values from a specific column, let’s say the Project column.
You can use the following format for the RowSource property: =Database!Data[Project]

Hopefully, the idea will help. I have also attached the solution workbook for better understanding. Good luck.

DOWNLOAD SOLUTION WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello RENE

Thanks for reaching out and sharing your problem. You have observed that the formula works for the first eight rows. When you expand to include cells B5:B144 and C5:C144, it returns #N/A. However, our machine works perfectly fine, even though we work with an extensive range. The FILTER function is only available in Excel for Microsoft 365 and Excel 2021. Assuming you are using one of these versions.

To resolve your problem, double-check the references in the formula to ensure they correspond to the correct columns and cells. Confirm that the formula is entered correctly without any typos or syntax errors. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello DENNIS IVAN FORD

For the Time_Box to work properly, paste the following code in the UserForm.

Private Sub Time_Box_Change()

    Dim cellValue As String
    
    cellValue = Selection.Value
    
    If cellValue <> "" Then
        If Time_Box.Value = True Then
            If InStr(1, cellValue, ":") > 0 Then
                Exit Sub
            Else
                Selection.Value = Selection.Value & ": " & Time()
            End If
    
        Else
            If InStr(1, cellValue, ":") > 0 Then
                Selection.Value = Left(cellValue, InStr(1, cellValue, ":") - 1)
            Else
                Exit Sub
            End If
        End If
    End If
    
End Sub

Through this code, the UserForm will be able to add time with a date when the Add Time check box is ticked.

Download the practice workbook provided in the article for better understanding. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello SHASHA

Thanks for reaching out and posting your question. I would say yes, you have found the solution to your problem. You can fix this problem by changing the date format in your computer’s date and time settings. Change the date format to your desired one.

However, I am delighted that I have an ultimate solution. I am presenting an Excel VBA sub-procedure that will display the date format based on the PC date & time setting.

OUTPUT Overview:

All you need to do is replace the existing Create_Calender sub-procedure with the following enhanced sub-procedure.

Sub Create_Calender()
        
    For i = 1 To 42
        If Application.International(xlDateOrder) = 0 Then
            
            If i < Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
            Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")
            
            Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "m/d/yyyy")
            
            ElseIf i >= Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
            Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")
            
            Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "m/d/yyyy")
            End If
            
            If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mmmm") = ((Month_Box.Value)) Then
            If Controls("C" & (i)).BackColor <> &HFFFFFF Then Controls("C" & (i)).BackColor = &HFFFFFF
            Controls("C" & (i)).Font.Bold = True
            
            If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "m/d/yyyy") = Format(This_Day, "m/d/yyyy") Then Controls("C" & (i)).SetFocus
            Else
            If Controls("C" & (i)).BackColor <> &H80000016 Then Controls("C" & (i)).BackColor = &H8000000F
            Controls("C" & (i)).Font.Bold = False
            End If
            
            
        ElseIf Application.International(xlDateOrder) = 1 Then
            
            
            If i < Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
            Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")
            
            Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d/m/yyyy")
            
            ElseIf i >= Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
            Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")
            
            Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d/m/yyyy")
            End If
            
            If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mmmm") = ((Month_Box.Value)) Then
            If Controls("C" & (i)).BackColor <> &HFFFFFF Then Controls("C" & (i)).BackColor = &HFFFFFF
            Controls("C" & (i)).Font.Bold = True
            
            If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d/m/yyyy") = Format(This_Day, "d/m/yy") Then Controls("C" & (i)).SetFocus
            Else
            If Controls("C" & (i)).BackColor <> &H80000016 Then Controls("C" & (i)).BackColor = &H8000000F
            Controls("C" & (i)).Font.Bold = False
            End If
            
        ElseIf Application.International(xlDateOrder) = 2 Then
            
            If i < Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
            Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")
            
            Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "yyyy/m/d")
            
            ElseIf i >= Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value)) Then
            Controls("C" & (i)).Caption = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "d")
            
            Controls("C" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "yyyy/m/d")
            End If
            
            If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "mmmm") = ((Month_Box.Value)) Then
            If Controls("C" & (i)).BackColor <> &HFFFFFF Then Controls("C" & (i)).BackColor = &HFFFFFF
            Controls("C" & (i)).Font.Bold = True
            
            If Format(DateAdd("d", (i - Weekday((Month_Box.Value) & "/1/" & (Year_Box.Value))), _
            ((Month_Box.Value) & "/1/" & (Year_Box.Value))), "yyyy/m/d") = Format(This_Day, "yyyy/m/d") Then Controls("C" & (i)).SetFocus
            Else
            If Controls("C" & (i)).BackColor <> &H80000016 Then Controls("C" & (i)).BackColor = &H8000000F
            Controls("C" & (i)).Font.Bold = False
            End If
            
        End If
    Next i

End Sub

Hopefully, the idea will help you good luck.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello Jon Jacobson

Thanks for your nice words. The code and font work perfectly fine in our machine for numbers greater than 999. See the following Image,

You can test the barcodes shown in the image using your barcode gun. On our end, we have found the original text accurately.

It is impossible to thoroughly observe your problem remotely and not glance at your machine. Make sure you have installed the Code 128 barcode font properly. You can check the scanner manual for specific settings related to Code 128 barcodes.

If you still face this type of problem, you can share the issue within the ExcelDemy Forum with details of your machine. Stay blessed.

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello KIMHONG

Thanks for sharing your query. In your case, an employee works 11 hours and starts working at 5:30 AM. If the overtime is between 0 and 15 minutes, you wanted a formula that returns 0 minutes. If it’s 15 minutes or more, it’s considered as 30 minutes.

You can achieve the goal by developing a formula using the IF and TIME functions. Follow these steps:

1. Select the intended cell.

2. Apply the following formula: =IF((E3-TIME(5,30,0)-(11/24) > TIME(0, 15, 0)), TIME(0, 30, 0)*24, TIME(0, 0, 0))

3. Drag the Fill Handle icon to copy the formula down.

Hopefully, the idea will help. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello KAJA POHAR

Thanks for your compliments. Your appreciation means a lot to us. You wanted to work with a read-only Excel file; however, you had issues with the existing VBA code.

I am delighted to inform you that I have developed an Excel VBA Sub-procedure by modifying the existing VBA code. The main idea behind the sub-procedure is it changes the File Access property to xlReadWrite, and before closing, it changes the File Access back to xlReadOnly.

Follow these steps:

1. Press Alt+F11 to open VBE.

2. Click on Insert followed by Module.

3. Paste the following code in the module and Run.

Public Sub AutoRefreshFile()

    Dim mrf As Object
    Dim mfile As Object
    Dim mPath As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show = -1 Then
            mPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Set mrf = CreateObject("Scripting.FileSystemObject")
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With
     
    If Right(mrf.GetFileName(mPath), 4) = "xlsx" Or Right(mrf.GetFileName(mPath), 3) = "xls" Then
        Dim wb As Workbook
        Set wb = Workbooks.Open(Filename:=mPath)
        
        If wb.ReadOnly = True Then
            wb.ChangeFileAccess Mode:=xlReadWrite
        End If
        
        If wb.ReadOnly Then
            wb.ChangeFileAccess Mode:=xlReadWrite
        End If
        
        wb.UpdateLink Name:=wb.LinkSources
        
        wb.ChangeFileAccess Mode:=xlReadOnly
        
        wb.Close SaveChanges:=True
    
    End If
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With

End Sub

As a result, you will see an output like the following GIF.

Hopefully, the idea will help you to reach your goal. Good luck!

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello NUNOF

Thanks for your beautiful words. Your appreciation means a lot to us. We are delighted to know you have learned a lot from our blog.

The issue you describe hampers performance for sure in such scenarios. I have gone through the article and also investigated your problem. What I have found: Perhaps you are calling your desired macro within another worksheet event like Worksheet_Calculate instead of the Worksheet_Change event of cell $K$10, which results in calling the macro unintentionally.

When the cell values change by formulas, the Worksheet_Change event will not trigger. So, call your macro or sub-procedure within a change event. In your case, the code within the sheet module can be like the following:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("K10")) Is Nothing Then
        
        Call GreetingToNUNOF
    
    End If

End Sub


Sub GreetingToNUNOF()
    MsgBox "Hello from ExcelDemy!"
End Sub

Hopefully, you have found the idea to overcome your situation. Good luck!

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello RAMNATH TAKIAR

Thanks a Ton! for your nice words. Your appreciation means a lot to us. Thank you once again for sharing your expertise with our ExcelDemy blog!

The extra values you have added prove effective. We appreciate you sharing your program with us, and we believe it will be valuable to others who visit our blog.

To generate even 500 random samples from the selected population of 200:
OUTPUT OVERVIEW:

Excel VBA Sub-procedure (Contributed by RAMNATH TAKIAR):

Sub Random_Sample()
    
    Dim xRow As Long
    Dim J As Long
    
    For J = 5 To 55
        Dim I As Long
        For I = 1 To 20
            xRow = [RandBetween(1,200)]
            Cells(I, J) = Cells(xRow + 1, 1)
        Next I
    Next J

End Sub

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello GSFRAGARO

Thanks for sharing your problem. You have encountered an issue like you have a string with two consecutive zeros, but the code generates an empty character. In Our machine, the code and font work perfectly fine if we have a string with two consecutive zeros. See the following Image,

The possible reason for the issue you encountered could be not using the Code 128 font. Maybe you are using some other barcode font. So, please ensure you are using the intended font. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello JOHN

Thanks for sharing your query. You wanted to split strings within Excel cells that do not always have 3 words separated by commas. In contrast, there can be a string like one or at most three words like the following image. Besides, we must keep the cell empty if more than 3 words mean more than 2 commas exist.

I am delighted to inform you that I have developed two formulas. The first formula consists of the IF, LEN, SUBSTITUTE, TRIM, and MID functions. The other formula consists of the IF, LEN, SUBSTITUTE, TRANSPOSE, and FILTERXML functions.
OUTPUT OVERVIEW:

1. Using IF, LEN, SUBSTITUTE, TRIM, and MID functions
Follow these steps:
Step 1: Select cell C5, insert the given formula and drag the Fill Handle icon to E5.

=IF(LEN($B5)-LEN(SUBSTITUTE($B5,”,”,””))>2,””,TRIM(MID(SUBSTITUTE($B5,”,”,REPT(” “,LEN($B5))),(C$4-1)*LEN($B5)+1,LEN($B5))))

Step 2: Select range C5:E5 and drag the Fill Handle icon to cell E10.

2. Using FILTERXML, TRANSPOSE, IF, LEN, and SUBSTITUTE functions

I am attaching the solution workbook for better understanding. I hope these ideas will help you to reach your goal. Good luck.

DOWNLOAD WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello ZAPPER

Thanks for reading ExcelDemy Blogs. You wanted a button to click and copy some sheets in a folder.

I am delighted to inform you that I have enhanced the sub-procedure so you will like it. The sub-procedure will create a folder dynamically, and the path will be the workbook path. Besides, it will handle errors as well. I have inserted a print icon and assigned the sub-procedure as follows.

OUTPUT OVERVIEW:

Enhanced Excel VBA Sub-procedure:

Sub AdvancedSaveSheetByArrayVariable()

    Dim currentPath As String
    currentPath = ThisWorkbook.Path
    
    Dim folderPath As String
    folderPath = currentPath & "\" & "SavedSheetsFolder"
    
    On Error GoTo ErrHandle
    
    MkDir folderPath
    
    Sheets(Array("dataset1", "dataset2", "dataset3")).Select
    Sheets("dataset1").Activate
    Sheets(Array("dataset1", "dataset2", "dataset3")).Copy

    With ActiveWorkbook
        .SaveAs Filename:=folderPath & "\" & "SaveSheetsByVBA_2.xlsx", CreateBackup:=False
        .Close False
    End With
    
    Exit Sub

ErrHandle:

    MsgBox "Folder and File Exist. Remove the previous folder and file.", vbCritical

End Sub

I am attaching the solution workbook for better understanding. Good luck.

DOWNLOAD WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello ASIF MAHMOOD

Thanks for reaching out and sharing your requirements with such clarity. You wanted to know how to convert a string like 159.3 B into a regular unit format (for example, 159300000000.00).

I am delighted to inform you that I have developed an Excel VBA Event Procedure that will trigger when a value is inserted in a format like 13 B in column B and convert the values into a regular unit. Besides, I have developed an Excel formula to fulfil your goal using the TEXT and SUBSTITUTE functions.

OUTPUT OVERVIEW (Excel VBA Event Procedure):

Follow these steps:

Step 1: Right-click on the sheet name tab => Click on View Code.

Step 2: Hover over Insert => Click on Module => Paste the following code in the module => Save.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets("Sheet2")

    Set IntersectRange = Intersect(Target, ws.Columns("B"))

    If Not Intersect(Target, ws.Columns("B")) Is Nothing Then
        
        Application.EnableEvents = False
        
        On Error Resume Next
    
        If Not IsEmpty(Target.Value) Then
            Target.Value = Application.WorksheetFunction.Text(Application.WorksheetFunction.Substitute(Target.Value, " B", "") * 1000000000, "0.00")
            Target.NumberFormat = "0.00"
        End If

        Application.EnableEvents = True
    
    End If

End Sub

OUTPUT OVERVIEW (Using Excel TEXT and SUBSTITUTE Functions):

Follow these steps:

Step 1: Select cell C5 => Insert the following formula => Hit Enter.

=TEXT(SUBSTITUTE(B5, ” B”, “”) * 1000000000, “0.00”)

Step 2: Drag the Fill Handle icon to cell C14 to copy the formula down.

I am also attaching the solution workbook for better understanding. Good luck.

DOWNLOAD WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello DAN H

Thanks for your nice words. Your appreciation means a lot to us. Thanks once again for sharing your requirements with such clarity.

You wanted to get an Excel VBA Sub-procedures or Excel VBA User-defined functions to calculate the distance between two addresses using Address String (for example, New York, Alaska) instead of Latitudes and Longitudes values.

I am delighted that I developed some Excel VBA User-defined functions to fulfil your requirements.

OUTPUT OVERVIEW:

Follow these steps:

Step 1: Hover over Insert => Click on Module => paste the following code in the module.

Public Function DistanceInKM(First_Location As String, Final_Location As String, Target_Value As String)

    Dim Initial_Point As String, Ending_Point As String, Distance_Unit As String, Setup_HTTP As Object, Output_Url As String
    Initial_Point = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins="
    Ending_Point = "&destinations="
    Distance_Unit = "&travelMode=driving&o=xml&key=" & Target_Value & "&distanceUnit=km"
    
    Set Setup_HTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    Output_Url = Initial_Point & First_Location & Ending_Point & Final_Location & Distance_Unit
    Setup_HTTP.Open "GET", Output_Url, False
    Setup_HTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    Setup_HTTP.send ("")
    DistanceInKM = Round(Round(WorksheetFunction.FilterXML(Setup_HTTP.responseText, "//TravelDistance"), 3), 0)
End Function

Public Function DistanceInMiles(First_Location As String, Final_Location As String, Target_Value As String)

    Dim Initial_Point As String, Ending_Point As String, Distance_Unit As String, Setup_HTTP As Object, Output_Url As String
    Initial_Point = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins="
    Ending_Point = "&destinations="
    Distance_Unit = "&travelMode=driving&o=xml&key=" & Target_Value & "&distanceUnit=mi"
    
    Set Setup_HTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    Output_Url = Initial_Point & First_Location & Ending_Point & Final_Location & Distance_Unit
    
    Setup_HTTP.Open "GET", Output_Url, False
    Setup_HTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    Setup_HTTP.send ("")
    DistanceInMiles = Round(Round(WorksheetFunction.FilterXML(Setup_HTTP.responseText, "//TravelDistance"), 3), 0)
End Function

Function Co_Ordinates(address As String) As String

    Application.Caller.Font.ColorIndex = xlNone
    Dim xDoc As New MSXML2.DOMDocument
    xDoc.async = False
    xDoc.Load ("https://nominatim.openstreetmap.org/search?format=xml&q=" + WorksheetFunction.EncodeURL(address))
    If xDoc.parseError.ErrorCode <> 0 Then
        Application.Caller.Font.ColorIndex = vbErr
        Co_Ordinates = xDoc.parseError.reason
    Else
        xDoc.SetProperty "SelectionLanguage", "XPath"
        Dim loc As MSXML2.IXMLDOMElement
        Set loc = xDoc.SelectSingleNode("/searchresults/place")
        If loc Is Nothing Then
            Application.Caller.Font.ColorIndex = vbErr
            NominatimGeocode = xDoc.XML
        Else
            Application.Caller.Font.ColorIndex = vbOK
            Co_Ordinates = loc.getAttribute("lat") & "," & loc.getAttribute("lon")
        End If
    End If

End Function

Step 2: Select cell C9 => Insert the following formula.

=DistanceInMiles(Co_Ordinates(C6),Co_Ordinates(C7),C2)

Step 3: Hit Enter to see the result in cell C9.

Step 4: Select cell C10 => Insert the following formula.

=DistanceInKM(Co_Ordinates(C6),Co_Ordinates(C7),C2)

Step 5: Hit Enter to see the result in cell C10.

Things to Keep in Mind: Ensure to check Microsoft XML, v3.0 from the References – VBAProject window.

I am attaching the solution workbook. Hopefully, these user-defined functions will help you reach your goal. Good luck.

DOWNLOAD WORKBOOK

Regards
Lutfor Rahman Shimanto
Excel & VBA Developer
ExcelDemy

Hello NURIT

Thanks for your nice words. Your appreciation means a lot to us. You wanted a VBA code that will ignore the text within a cell and sum only the number portion on that cell of the S8:AO43 range based on specific conditionally formatted colors.

I am delighted to inform you that I have developed an Excel VBA User-defined function to fulfil your goal.

OUTPUT OVERVIEW:

Excel VBA User-defined Function:

Function SumColoredCells(rng As Range, colorIndex As Long) As Double

    Dim cell As Range
    Dim sumValue As Double

    sumValue = 0

    For Each cell In rng
        If cell.Interior.colorIndex = colorIndex Then

            Dim numericPart As Double
            numericPart = Val(Mid(cell.Value, 4))

            sumValue = sumValue + numericPart
        End If
    Next cell

    SumColoredCells = sumValue

End Function

Follow these steps:
Step 1: Open the VBA Editor window => Hover over Insert and click on Module => Insert the code above in the module and Save.

Step 2: Select cell P20 => Insert the following formula => Hit Enter.

=SumColoredCells(S8:AO43,43)

Hopefully, the idea will help you. Good luck.

Regards
Lutfor Rahman Shimanto
ExcelDemy

Dear AVA

Your appreciation means a lot to us. Thanks for describing your problem with such clarity. You want a column of comments and a column of texts in which a comment was made (e.g. Josef Albers | Artist).

I am delighted to let you know that I modified the previous code to fulfil your requirements.

Excel VBA Sub-procedure:

Sub AdvancedExtractCommentsAndTextToExcel()

    Dim xAPP As Object
    Dim xWB As Workbook
    Dim xDoc As Object
    Dim j As Integer
    Dim filePath As String
    
    filePath = "C:\Users\User\Downloads\AVA-DEMO-DOC.docx"
    
    Set xAPP = CreateObject("Word.Application")
    xAPP.Visible = True
    
    Set xDoc = xAPP.Documents.Open(filePath)
    
    Set xWB = Application.ThisWorkbook
    
    With xWB.Worksheets(1)

        For j = 1 To xDoc.Comments.Count
            '.Cells(j, 1).Formula = xDoc.Comments(j).Initial
            .Cells(j, 2).Formula = xDoc.Comments(j).Range.Text
            .Cells(j, 3).Formula = xDoc.Comments(j).Scope.Text
            '.Cells(j, 4).Formula = Format(xDoc.Comments(j).Date, "dd/MM/yyyy")
        Next j
    End With
    
    xDoc.Close False
    
    Set xWB = Nothing
    Set xDoc = Nothing
    Set xAPP = Nothing

End Sub

OUTPUT OVERVIEW:

I hope the code presented will make your task easier. Good luck!

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello GURU

Thanks for sharing your queries. Your Excel Data is like “01/01/23 14.20 PM” (24-Hour Clock Time does not need AM/PM extensions). You want to store “01/01/23” and “14.20 PM” in another column.

I am presenting another sub-procedure that will fulfil your requirements by modifying the sub-procedure mentioned in the article.

Excel VBA Sub-procedure:

Sub AdvancedSplitDateAndTime()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim dateWithTime As Date
    Dim separatedDate As Date
    Dim separatedTime As Date

    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ws.Range("C:C").NumberFormat = "[$-en-US]h:mm AM/PM;@"
    
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    For i = 1 To lastRow

        dateWithTime = ws.Cells(i, 1).Value

        separatedDate = DateSerial(Year(dateWithTime), Month(dateWithTime), Day(dateWithTime))
        separatedTime = TimeValue(Format(dateWithTime, "h:mm AM/PM"))

        ws.Cells(i, 3).Value = separatedTime

        ws.Cells(i, 2).Value = separatedDate

    Next i
    
End Sub

OUTPUT OVERVIEW:

You have one more doubt when using Text to Column features. Typically, the Text to Column features will display dates in the desired format you mention. You can apply a custom format like “m/d/yyyy” after that if it does not.

Hopefully, the suggestions and the presented code will help you. Good luck!

Regards
Lutfor Rahman Shimanto

Hello LUIS CARRERA

Thanks for sharing your problem. The error you are facing is like the following:

Run-time error ‘1004’
Application-defined or object-defined error

On the line below:

Set RG = RG.Offset(1, 0)

The error arises from setting the range offset outside the worksheet’s boundaries. The range RG starts at cell H5, and when you try to set the offset to (1, 0), it might go beyond the last row of the worksheet.

However, I am presenting an Excel VBA code to handle that error.

Excel VBA Code:

Sub AdvancedCombinationsFor6Columns()
    
    On Error GoTo ErrorHandler
    
    Dim X1, X2, X3, X4, X5, X6 As Range
    Dim RG As Range
    Dim xStr As String
    Dim FN1, FN2, FN3, FN4, FN5, FN6 As Integer
    Dim SV1, SV2, SV3, SV4, SV5, SV6 As String
    
    Set X1 = Range("B5:B19")
    Set X2 = Range("C5:C19")
    Set X3 = Range("D5:D19")
    Set X4 = Range("E5:E19")
    Set X5 = Range("F5:F19")
    Set X6 = Range("G5:G19")
    
    xStr = " - "
    
    Set RG = Range("H5")
    For FN1 = 1 To X1.Count
        SV1 = X1.Item(FN1).Text
        For FN2 = 1 To X2.Count
            SV2 = X2.Item(FN2).Text
            For FN3 = 1 To X3.Count
                SV3 = X3.Item(FN3).Text
                For FN4 = 1 To X4.Count
                    SV4 = X4.Item(FN4).Text
                    For FN5 = 1 To X5.Count
                        SV5 = X5.Item(FN5).Text
                        For FN6 = 1 To X6.Count
                            SV6 = X6.Item(FN6).Text
                            RG.Value = SV1 & xStr & SV2 & xStr & SV3 & xStr & SV4 & xStr & SV5 & xStr & SV6
                            Set RG = RG.Offset(1, 0)
                        Next
                    Next
                Next
            Next
        Next
    Next
    
    Exit Sub
    
ErrorHandler:

    Exit Sub

End Sub

Hopefully, the code will work perfectly for you. Good luck.

Regards
Lutfor Rahman Shimanto

Hello YVONNE

Thanks for reaching out and sharing your query. You wanted a formula to find duplicates when columns can be suffered, like Laura & China and China & Laura.

I have developed two formulas that will fulfil your requirements using the IF and COUNTIF functions. I will use column C as a Helper column, displaying the result in column D.

Follow these steps:

Step 1: Select cell D5 => Insert the given formula => Drag the Fill Handle icon to cell D10.

=IF(B5 < C5, B5 & " " & C5, C5 & " " & B5)

Step 2: Select cell D5 => Insert the given formula => Drag the Fill Handle icon to cell D10.

=IF(COUNTIF($D$5:$D$10, D5)>1, “Duplicates”, “No Duplicates”)

Hopefully, you have got the solution. Good luck.

Regards
Lutfor Rahman Shimanto

Hello CYNTHIA

Thanks for visiting our blogs and sharing your queries. You want to know how to initialize the weight in the method 3. When investigating your problem, we found that the dataset we previously used does not suit the weighted moving average formula. So, we have modified the article (method 3) for better understanding.

When implementing a weighted moving average formula, it is better to fix the total weight first and distribute the weights among durations. So, please go to method 3 of this article again. Hopefully, you will not have any doubts. Good luck!

Regards
Lutfor Rahman Shimanto
ExcelDemy

Hello Greg

Thanks for your nice words. Your appreciation means a lot to us. You wanted to know the formula for adding a Double time column for anything above 12 hours daily.

I am delighted to inform you that I have developed an Excel Formula using the IF and TIME functions to fulfil your requirements.

Follow these steps:

Step 1: Select cell G11 => Insert the following formula.

=IF(F11-TIME(12,0,0)<0,0,F11-TIME(12,0,0))

Step 2: Hit Enter to see the result, like the image below.

Step 3: Hover over the cursor on the right button corner of cell G11 to see the Fill Handle icon.

Step 4: Drag the Fill Handle icon to cell G18 to copy down the formula.

Hopefully, this idea will help you reach your goal. Good luck!

Regards
Lutfor Rahman Shimanto

Hello ALAN FARTHING

Thanks for reaching out and sharing your problem. I found a Syntax Error within your given code. You have to write the .sort property within the With block.

Corrected Sub-procedure:

Sub Ascending_Order_Sorting()
    With ActiveWorkbook.Worksheets("Grid_Reference_Tables").Range("Grid_Reference")
        .Sort key1:=.Columns(1), order1:=xlAscending, Header:=xlYes
    End With
End Sub

OUTPUT:

Hopefully, the correction resolves your problem. Stay blessed.

Regards
Lutfor Rahman Shimanto

Hello XU

Thanks for thanking me. Your appreciation means a lot to us. You wanted to convert UTM (UTM Easting, UTM Northing and UTM Zone) to Latitude and Longitude values.

I am presenting some Excel VBA User-Defined functions, and these functions will achieve your goal.

Follow these Steps:

Step 1: Open the VBA Editor window => Paste the following code in a module => Save.

Function CalculateLatitude(UTMNorthing As Double, UTMZone As Integer) As Double
    
    Dim EquatorialRadius As Double
    EquatorialRadius = 6378137#


    Dim EccentricitySquared As Double
    EccentricitySquared = 0.00669438

    Dim UTMScaleFactor As Double
    UTMScaleFactor = 0.9996

    Dim UTMFalseNorthing As Double
    If UTMNorthing < 0 Then
        UTMFalseNorthing = 10000000
    Else
        UTMFalseNorthing = 0
    End If

    Dim M As Double
    M = UTMNorthing / UTMScaleFactor - UTMFalseNorthing

    Dim Mu As Double
    Mu = M / (EquatorialRadius * (1 - EccentricitySquared / 4 - 3 * EccentricitySquared ^ 2 / 64 - 5 * EccentricitySquared ^ 3 / 256))

    Dim Phi1Rad As Double
    Phi1Rad = Mu + (3 * EccentricitySquared / 2 - 27 * EccentricitySquared ^ 3 / 32) * Sin(2 * Mu) _
                + (21 * EccentricitySquared ^ 2 / 16 - 55 * EccentricitySquared ^ 4 / 32) * Sin(4 * Mu) _
                + (151 * EccentricitySquared ^ 3 / 96) * Sin(6 * Mu) _
                + (1097 * EccentricitySquared ^ 4 / 512) * Sin(8 * Mu)

    Dim phi1 As Double
    phi1 = Phi1Rad * 180 / 3.14159265358979

    Dim N1 As Double
    N1 = EquatorialRadius / Sqr(1 - EccentricitySquared * Sin(Phi1Rad) ^ 2)

    Dim T1 As Double
    T1 = Tan(Phi1Rad) ^ 2

    Dim C1 As Double
    C1 = EccentricitySquared * Cos(Phi1Rad) ^ 2

    Dim R1 As Double
    R1 = EquatorialRadius * (1 - EccentricitySquared) / ((1 - EccentricitySquared * Sin(Phi1Rad) ^ 2) ^ 1.5)

    Dim D As Double
    D = (UTMNorthing / (N1 * UTMScaleFactor))

    Dim Latitude As Double
    Latitude = Phi1Rad - (N1 * Tan(Phi1Rad) / R1) * (D ^ 2 / 2 - (5 + 3 * T1 + 10 * C1 - 4 * C1 ^ 2 - 9 * EccentricitySquared) * D ^ 4 / 24 + (61 + 90 * T1 + 298 * C1 + 45 * T1 ^ 2 - 3 * C1 ^ 2 - 252 * EccentricitySquared) * D ^ 6 / 720)

    CalculateLatitude = Latitude * 180 / 3.14159265358979

End Function

Function CalculateLongitude(UTMEasting As Double, UTMZone As Integer) As Double
    
    Dim CentralMeridian As Double
    CentralMeridian = (UTMZone - 1) * 6 - 180 + 3

    Dim ScaleFactor As Double
    ScaleFactor = 0.9996

    Dim EquatorialRadius As Double
    EquatorialRadius = 6378137#

    Dim EccentricitySquared As Double
    EccentricitySquared = 0.00669438

    Dim UTMEastingShifted As Double
    UTMEastingShifted = UTMEasting - 500000

    Dim A1 As Double
    A1 = Cos(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) * UTMEastingShifted / (EquatorialRadius * ScaleFactor)

    Dim A2 As Double
    A2 = -Sin(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) * UTMEastingShifted / (EquatorialRadius * ScaleFactor)

    Dim A3 As Double
    A3 = Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) * UTMEastingShifted / (EquatorialRadius * ScaleFactor)

    Dim A4 As Double
    A4 = -Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) * UTMEastingShifted / (EquatorialRadius * ScaleFactor) ^ 3 * (1 + Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) ^ 2) / 2

    Dim A5 As Double
    A5 = Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) * UTMEastingShifted / (EquatorialRadius * ScaleFactor) ^ 5 * (5 + 3 * Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) ^ 2 + 6 * Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) ^ 4) / 24

    Dim A6 As Double
    A6 = -Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) * UTMEastingShifted / (EquatorialRadius * ScaleFactor) ^ 7 * (61 + 90 * Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) ^ 2 + 45 * Tan(CalculateLatitude(0, UTMZone) * 3.14159265358979 / 180) ^ 4) / 720

    Dim Longitude As Double
    Longitude = CentralMeridian + (A1 + A2 + A3 + A4 + A5 + A6) * 180 / 3.14159265358979

    CalculateLongitude = Longitude

End Function

Function GetUTMZoneNumber(UTMZone As String) As Integer
    GetUTMZoneNumber = Val(Left(UTMZone, Len(UTMZone) - 1))
End Function

Step 2: Return to the sheet => Choose cell E4 => Insert the following formula => And drag the Fill Handle icon to cell E11.

=CalculateLatitude(C4,GetUTMZoneNumber(D4))

Step 3: Choose cell F4 => Insert the following formula => And drag the Fill Handle icon to cell F11.

=CalculateLongitude(B4,GetUTMZoneNumber(D4))

Things to Keep in Mind:
As we cannot use all decimal points for some values (UTM Northing), we may not get the same value (Latitude) like previous one.

Hopefully, the idea will help you. Good luck.

Regards
Lutfor Rahman Shimanto

Hello SUBBARAMAN

Thanks for reaching out and sharing your requirements. Your appreciation means a lot to us. Thanks once again.

You want to analyze the Indian Stock Markets. To achieve your goal, you only need to use the Indian company names, and the rest of the procedure is described in the article.

Like the following GIF, I generated the intended data for some noted Indian Companies.

So, type the Indian company names and follow the steps of this article. Good luck!

Regards
Lutfor Rahman Shimanto

Hello ADAM INGLETON

Thanks for reaching out and posting an exciting query. You are right about the run-time error “13” Type mismatch. This is because the active sheet contains text value within cell B4.

I am delighted to inform you that I have developed other improved sub-procedures that have overcome the issue you mentioned by modifying the previous code. To be specific, I have taken a worksheet object to avoid this error.

Raised Error on Your End:

Improved Sub-procedures:

Open the VBA Editor window => Click on Insert followed by Module => Paste the following code in the module => Save.

Option Explicit
Public countDown As Date

Sub StartTimer()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Stopwatch")

    countDown = Now + TimeValue("00:00:01")
    ws.Range("B4") = ws.Range("B4") + TimeValue("00:00:01")
    Application.OnTime countDown, "StartTimer"

End Sub

Sub ResetTimer()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Stopwatch")

    ws.Range("B4") = TimeValue("00:00:0")

End Sub

Sub StopTimer()
    Application.OnTime EarliestTime:=countDown, Procedure:="StartTimer", Schedule:=False
End Sub

OUTPUT of Applying the Improved Sub-procedures:

Hopefully, the idea will resolve your problem. Good luck!

Regards
Lutfor Rahman Shimanto