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 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

Hello AJK

Thanks for sharing this exciting issue with us. The mentioned site arranges the required information on many pages. When I went through, there were 69 pages (25 records are displayed on each page). However, the page numbers will change over time. You wanted to use the PowerQuery and fetch all the information into a single sheet.

I am delighted to inform you that I have developed an Excel VBA Sub-procedure to fulfil your requirements. Thanks to MD. ABDUR RAHIM RASEL. I developed such an Excel VBA Sub-procedure by considering the idea he had given in the previous comment.

Excel VBA Sub-procedure:

Sub FetchDataFromAllPagesOfAWeb()

    Dim pageNumber As Integer
    Dim urlBase As String
    Dim queryName As String
    Dim queryFormula As String
    Dim ws As Worksheet
    Dim startCell As Range
    Dim masterSheet As Worksheet

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set masterSheet = ThisWorkbook.Sheets.Add
    masterSheet.Name = "Master Sheet"
    
    Call deleteQueriesAndConnections

    urlBase = "https://www.screener.in/screens/16162/all-stocks/?sort=name&order=asc&page="
    pageNumber = 1

    Do While pageNumber <= 69
        
        queryName = "Table_" & pageNumber - 1

        queryFormula = "let" & Chr(13) & Chr(10) & _
            "    Source = Web.Page(Web.Contents(""" & urlBase & pageNumber & """))," & Chr(13) & Chr(10) & _
            "    Data0 = Source{0}[Data]," & Chr(13) & Chr(10) & _
            "    #""Changed Type"" = Table.TransformColumnTypes(Data0,{{""S.No."", Int64.Type}, {""Name"", type text}, {""CMP Rs."", type number}, {""P/E"", type number}, {""Mar Cap Rs.Cr."", type number}, {""Div Yld %"", type number}, {""NP Qtr Rs.Cr."", type number}, {""Qtr Profit Var %"", type number}, {""Sales Qtr Rs.Cr."", type number}, {""Qtr Sales Var %"", type number}, {""ROCE %"", type number}, {""Debt / Eq"", type number}, {""B.V. Rs."", type number}})" & Chr(13) & Chr(10) & _
            "in" & Chr(13) & Chr(10) & _
            "    #""Changed Type"""

        Set ws = ThisWorkbook.Sheets.Add
        ws.Name = "Page_" & pageNumber

        ActiveWorkbook.Queries.Add Name:=queryName, Formula:=queryFormula

        With ws.ListObjects.Add(SourceType:=0, Source:= _
            "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""" & queryName & """;Extended Properties=""""" _
            , Destination:=ws.Cells(2, 1)).QueryTable
            .CommandType = xlCmdSql
            .CommandText = Array("SELECT * FROM [" & queryName & "]")
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .PreserveColumnInfo = True
            .ListObject.DisplayName = queryName
            .Refresh BackgroundQuery:=False
        End With

        ws.UsedRange.Copy Destination:=masterSheet.Cells(masterSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)

        'ThisWorkbook.Queries(queryName).Delete

        pageNumber = pageNumber + 1
    Loop

    Dim wsToDelete As Worksheet
    For Each wsToDelete In ThisWorkbook.Sheets
        If wsToDelete.Name <> "Master Sheet" Then
            wsToDelete.Delete
        End If
    Next wsToDelete
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Sub deleteQueriesAndConnections()
    
    Dim QueriesAndConnections As Object
    
    For Each QueriesAndConnections In ThisWorkbook.Queries
        QueriesAndConnections.Delete
    Next
    
End Sub

OUTPUT:

Things to Remember:

1. Add a new sheet and delete the Master Sheet before running the Excel VBA Code.

2. At the end of the code execution, the code will delete all sheets except for the Master Sheet.

Limitations: The code will take 10 to 15 minutes to fetch data from that site. It will depend on the capacity of your computer and internet connection.

I am attaching the solution workbook for better understanding. Good luck!
Download Solution Workbook

Regards
Lutfor Rahman Shimanto

Hello MIGHTY

Thanks for reaching out and posting your comment. You are right about the plan described in Method 2, but partially. Here, we could not maintain the proposal date for Task D. As mentioned in the article, we had to delay. The predecessor of Task D was Task C, which had been completed on the 10th of May. In that sense, we can say the plan made is impossible to follow. But, we must keep in mind that if we cannot start the project at the proposed time, it does not mean we are not completing it at the proposed end date. Maybe the project will end at the proposed date.

In project management, it’s common to have tasks that depend on completing other tasks. It’s a fundamental aspect of project planning to identify and manage task dependencies and ensure the project is executed in a logical and efficient order. When you have such dependencies, you need to adjust the schedule accordingly to ensure that tasks are performed in the correct sequence.

Regards
Lutfor Rahman Shimanto

Hello HEATHER

Thanks for reaching out and posting your comment. You are right about the results from using Geography Datatypes and Excel VBA user-defined functions being slightly different. However, a valid API endpoint in VBA code will give you accurate results like the Geography datatypes.

If you are a Microsoft 365 user, I recommend using the first method, where you can use Geography datatype. I have presented the Excel VBA to other Excel users. However, I must admit that using the Geography is more accurate than the Excel VBA user-defined functions.

Regards
Lutfor Rahman Shimanto

Hello NIRMAL

Thanks for reaching out and posting your comment. You asked if it is possible to insert images in a particular size in Excel using the same code or not. The answer is Yes. As mentioned in the article, you can easily set the .height and .width properties for customization.

I am going to present a modified version of the given code mentioned in the third method to handle some errors.

Excel VBA Event Procedure:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim ws As Worksheet
    Dim dropdownCell As Range
    Dim img As Object
    Dim imgPath As String
    Dim imgName As String

    Set ws = ThisWorkbook.Sheets("method 3")
    Set dropdownCell = ws.Range("B4")

    If Not Intersect(Target, dropdownCell) Is Nothing And dropdownCell.Value <> "" Then

        imgName = dropdownCell.Value & ".jpg"
        
        imgPath = "C:\Users\Lutfor Rahman\Downloads\Insert Pictures\" & imgName
        
        If Dir(imgPath) <> "" Then
            Set img = ws.Pictures.Insert(imgPath)
            With img
                .Left = ws.Range("B5").Left
                .Top = ws.Range("B5").Top
                .Width = 70
                .Height = 70
            End With
        Else
            MsgBox "Image not found in the specified folder."
        End If
    End If

End Sub

Hopefully, the idea will fulfil your requirements. Good luck!

Regards
Lutfor Rahman Shimanto

Hello MX A HUSKINS

Thank you for reaching out and posting your comment. You are right about setting up your own valid Bing API to work properly.

The API Key will become an invalid one If 3 months or 10K transactions are reached. The API mentioned in this article may have reached 10 K transactions.

Regards
Lutfor Rahman Shimanto

Hello AISHWARYA ROY

Thanks for reaching out and posting your query with such clarity. You want to add new rows with certain information using a cell value. Some rows contain text that can be a mixture of three texts: peanut butter and jelly sandwich. You want to add the new rows accordingly and insert values like 1. Peanut butter, 2. Jelly and 3. Bread.

I am delighted to inform you that I have developed an Excel VBA procedure that will fulfil your requirements.

Navigate to Developer >> click on Visual Basic.

Due to this, the VBA Editor window will appear.

1. Hover over Insert and click on Module.

2. Paste the following code and Run.

Sub InsertRowsAndValues()

    Dim ws As Worksheet
    Dim i As Long
    Dim cell As Range
    Dim keywordCount As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    For i = 2 To 100
        Set cell = ws.Cells(i, "B")
        keywordCount = 0
        
        If InStr(1, cell.Value, "Peanut Butter", vbTextCompare) > 0 Then
            keywordCount = keywordCount + 1
        End If
        
        If InStr(1, cell.Value, "Jelly Sandwich", vbTextCompare) > 0 Then
            keywordCount = keywordCount + 1
        End If
        
        If InStr(1, cell.Value, "Bread", vbTextCompare) > 0 Then
            keywordCount = keywordCount + 1
        End If
        
        If keywordCount > 0 Then
            ws.Rows(i + 1 & ":" & i + keywordCount).Insert Shift:=xlDown
            
            For j = 1 To keywordCount
                ws.Cells(i + j, "B").Value = j & ". " & Choose(j, "Peanut Butter", "Jelly Sandwich", "Bread")
            Next j
            
            i = i + keywordCount
        End If
    Next i

End Sub

Finally, you will see an output like the following one.

I am also attaching the solution workbook to help you understand better. Good luck!
WORKBOOK

Regards
Lutfor Rahman Shimanto

Hello DENNIS

Thanks for reaching out and noticing the problem. You are right about the Date values not being formatted as expected for 1st to 12th.

I am delighted to inform you that I have come up with a solution. You must choose a date format consistently while inserting date values in cells.

In this case, use the exact Date Picker mentioned in the article, which typically chooses the data format as mm-dd-yyyy. Next, you have to create an extra command button that will be responsible for inserting the chosen date value in cell B10. And the Excel VBA Event procedure will convert the date format into dd-mm-yyyy.

VBA Code for CommandButton1: Double-click on the inserted CommandButton1 >> insert the following code and Save. You can also change the destination cell by modifying the code.

Private Sub CommandButton1_Click()

    Cells(10, 2) = UserForm1.CsnDate.Caption

End Sub

Excel VBA Event Procedure: Insert the following code in the intended sheet module described in my previous reply.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim Cell As Range
    
    If Not Intersect(Target, Me.UsedRange) Is Nothing Then
        
        For Each Cell In Target
            If IsDate(Cell.Value) Then
                Cell.NumberFormat = "dd-mm-yyyy"
            End If
        Next Cell
        
    End If

End Sub

OUTPUT:

Hopefully, the idea will resolve your issue. Stay Blessed.

Regards
Lutfor Rahman Shimanto

Hello JAMIE

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

You often click the stop button after you have already stopped the timer. That results in an Error. Thank you once again for noticing the issue. Your claim is correct.

However, I am delighted to inform you that the issue can be avoided with the help of an Error Handler called On Error Resume Next.

All you need to do is to modify the StopTime sub-procedure to fulfil your requirement.

Modified Excel VBA Code:

Option Explicit
Public countDown As Date
Sub StartTimer()
    countDown = Now + TimeValue("00:00:01")
    Range("B4") = Range("B4") + TimeValue("00:00:01")
    Application.OnTime countDown, "StartTimer"
End Sub
Sub ResetTimer()
    Range("B4") = TimeValue("00:00:0")
End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=countDown, Procedure:="StartTimer", Schedule:=False
End Sub

Good luck!

Regards
Lutfor Rahman Shimanto

Dear Faisal

Thanks a ton. Your appreciations mean a lot to us. I am glad you have found the article very helpful.

You mentioned the user-defined functions only work for UTM Zone and UTM Easting on your end. The user-defined function for calculating UTM Northing is not working.

However, the issue you are addressing is unclear to us. On our end, it is working perfectly. I am using Microsoft 365. However, It should not make any difference. The code should work for all versions of Excel.

Please share your workbook containing a dataset with us. You can also post your query and attach the dataset in ExcelDemy Forum. We need more information about your problem, such as if it returns any error or wrong values.

The functions often may return values using scientific notation like 2.34344E+13. To avoid this type of notation, you may use an Event procedure.

Excel VBA Event Procedure:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cell As Range
    Dim funcName As String

    funcName = "CalculateUTM"

    For Each cell In Target
        If InStr(1, cell.Formula, funcName) > 0 Then
            cell.NumberFormat = "0.00"
        End If
    Next cell

End Sub

I am looking forward to receiving your reply. Stay blessed and Good luck.

Regards
Lutfor Rahman Shimanto

Hello MOSES

Thanks for reaching out and posting your comment. You are absolutely right. However, I am delighted to inform you that I have modified the article. After going through the article, you must be able to convert Lat Long to UTM Easting, Northing and Zone. I have developed some user-defined functions using Excel VBA to achieve the goal.

Regards
Lutfor Rahman Shimanto

Hello ANAND,

Thanks for reaching out and posting your interesting issue. The requirement you mentioned can be done with the help of an Excel VBA code. The code contains two sub-procedures named ImportVCFRecordWise and ExtractData. All you have to do is to run the ImportVCFRecordWise procedure to achieve your goal.

Excel VBA Code:

Sub ImportVCFRecordWise()

    Dim wb As Workbook
    Dim ws, wsTemp As Worksheet
    Dim filePath As String
    Dim fileDialog As fileDialog
    
    Set wsTemp = Sheets.Add(After:=ActiveSheet)
    wsTemp.Name = "Temp"
    
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    
    fileDialog.Filters.Clear
    fileDialog.Filters.Add "VCF Files", "*.vcf"
    
    If fileDialog.Show = -1 Then
        filePath = fileDialog.SelectedItems(1)
        Set wb = Workbooks.Open(Filename:=filePath)
        With wb.Sheets(1)
            .UsedRange.Copy wsTemp.Range("A1")
        End With
        wb.Close SaveChanges:=False
    End If
    
    Call ExtractData
    
    For Each ws In ThisWorkbook.Sheets
        If ws.Name = "Temp" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next ws
    
    Set fileDialog = Nothing

End Sub

Sub ExtractData()

    Dim ws As Worksheet
    Dim outputRow As Long
    Dim lastRow As Long
    Dim outputSheet As Worksheet
    
    Set ws = ThisWorkbook.Sheets("Temp")
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Set outputSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    
    outputSheet.Name = "Output"
    outputSheet.Range("A1").Value = ws.Range("A2").Value
    outputSheet.Range("B1").Value = ws.Range("A3").Value
    outputSheet.Range("C1").Value = ws.Range("A4").Value
    outputSheet.Range("D1").Value = ws.Range("A5").Value
    outputSheet.Range("E1").Value = ws.Range("A6").Value
    outputSheet.Range("F1").Value = ws.Range("A7").Value
    outputSheet.Range("G1").Value = ws.Range("A8").Value
    
    outputRow = 2
    
    Dim vcardData As Variant
    vcardData = ws.Range("A1:B" & lastRow).Value
    
    Dim i As Long
    For i = 1 To UBound(vcardData, 1)
        If vcardData(i, 1) = "BEGIN" And vcardData(i, 2) = "VCARD" Then
            outputSheet.Range("A" & outputRow).Value = vcardData(i + 1, 2)
            outputSheet.Range("B" & outputRow).Value = vcardData(i + 2, 2)
            outputSheet.Range("C" & outputRow).Value = vcardData(i + 3, 2)
            outputSheet.Range("D" & outputRow).Value = vcardData(i + 4, 2)
            outputSheet.Range("E" & outputRow).Value = vcardData(i + 5, 2)
            outputSheet.Range("F" & outputRow).Value = vcardData(i + 6, 2)
            outputSheet.Range("G" & outputRow).Value = vcardData(i + 7, 2)
            outputRow = outputRow + 1
        End If
    Next i
    
    outputSheet.UsedRange.EntireColumn.AutoFit

End Sub

Solution Workbook: Download the Workbook used to solve the issue.
DOWNLOAD WORKBOOK

VCF File: The VCF file contains some raw data. I am using the data described in this article to be more specific.

Steps:

Press Alt+F11 >> insert the mentioned code >> press F5 or click on Run.

Choose the intended VCF file >> click on OK.

As a result, we will see an output like the following one.

Things to Keep in Mind:

1. You have to run only the ImportVCFRecordWise procedure.

2. You must delete the Output sheet if it exists before running the code.

This concept will assist you in reaching your goal. Good luck!

Regards
Lutfor Rahman Shimanto

Hello DeAnna

Thanks for reaching out. To overcome the situation, I will introduce another method. Here you must convert the locations into Geography data types. Later, you will find the Lat Long values for each location. Lastly, you have to call the below User-defined function in a cell.

Excel VBA Code:

Public Function GetTotalDistance2Locations(startlocation As String, endlocation As String, keyvalue As String) As Double

    Dim Initial_Value As String, temp_Value As String, Destination_Value As String, mitHTTP As Object, mitUrl As String
    Dim distance As Double
    
    Initial_Value = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins="
    temp_Value = "&destinations="
    Destination_Value = "&travelMode=driving&o=xml&key=" & keyvalue & "&distanceUnit=mi"
    
    Set mitHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    mitUrl = Initial_Value & startlocation & temp_Value & endlocation & Destination_Value
    mitHTTP.Open "GET", mitUrl, False
    mitHTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    mitHTTP.Send ("")

    distance = Round(Round(WorksheetFunction.FilterXML(mitHTTP.ResponseText, "//TravelDistance"), 3), 0)
    
    GetTotalDistance2Locations = distance

End Function

API:

AoCgFc5qOKVpyHuiGyPBgzDk8RgQnGGMvNqwcmtxfj7VnHEm-bpqH2GkRpoSJSAD

STEPS:
Select range B3:B4 >> go to Data tab >> click on Geography.

Choose cell C3 >> apply the below formula >> drag the Fill Handle to C4.

=B3.Latitude &”, “&B3.Longitude

Press Alt+F11 >> go to Insert >> click on Module >> insert the mentioned code.

Choose cell C9 >> apply the below formula.

=GetTotalDistance2Locations(C3,C4,A7)

This concept will assist you in reaching your goal. I’ve also attached the Solution Workbook to help you understand it better. Best wishes.

Download Workbook

Regards
Lutfor Rahman Shimanto

Hello PCLOUD

Greetings from our website! Thank you for sharing your question on the platform. There is a way to resolve your submitted query of finding the maximum value of the Close price in a defined period instead of the whole table. I can assist you with an Excel PowerQuery code to reach your goal.

PowerQuery Code:

let
    Source = Csv.Document(Web.Contents("https://query1.finance.yahoo.com/v7/finance/download/MSFT?period1=1589932800&period2=1590710400&interval=1d&events=history&includeAdjustedClose=true"),[Delimiter=",", Columns=7, Encoding=65001, QuoteStyle=QuoteStyle.None]),
    #"Promoted Headers" = Table.PromoteHeaders(Source, [PromoteAllScalars=true]),
    #"Changed Type" = Table.TransformColumnTypes(#"Promoted Headers",{{"Date", type date}, {"Open", type number}, {"High", type number}, {"Low", type number}, {"Close", type number}, {"Adj Close", type number}, {"Volume", Int64.Type}}),
    MaxClosePrice = List.Max(#"Changed Type"[Close])
in
    MaxClosePrice

The line MaxClosePrice = List.Max(#”Changed Type”[Close]) calculates the maximum value of the Close column in the transformed table. The result is assigned to the variable MaxClosePrice.

I hope this will achieve your goal. I am also giving you the Workbook used to investigate your issue to help you understand better. Feel free to contact us again with any other inquiries or concerns.

WORKBOOK:
DOWNLOAD WORKBOOK

Regards
Lutfor Rahman Shimanto
ExcelDemy Team

Hello DREW7STER,

Greetings from our website! Thank you for posting your question on the platform. There is a way to solve your submitted problem of finding the unique values and their frequency. I am providing an Excel VBA code compatible with several unique values, as many as you want to be more specific.

Excel VBA Code:

Sub FindUniqueValues()
    
    Dim uniqueValues As Variant
    Dim i As Long
    Dim j As Long
    Dim freq As Long
    
    uniqueValues = getUniqueValues(Range("B4:B" & Range("B" & Rows.Count).End(xlUp).Row))
    
    Range("E4:F" & Range("E" & Rows.Count).End(xlUp).Row).ClearContents
    
    For i = LBound(uniqueValues) To UBound(uniqueValues)
        freq = 0
        For j = 4 To Range("B" & Rows.Count).End(xlUp).Row
            If Range("B" & j).Value = uniqueValues(i) Then
                freq = freq + 1
            End If
        Next j
        Range("E" & (i + 4)).Value = uniqueValues(i)
        Range("F" & (i + 4)).Value = freq
    Next i
    
End Sub

Function getUniqueValues(rng As Range) As Variant
    
    Dim uniqueValues() As Variant
    Dim cellValue As Variant
    Dim i As Long, j As Long
    Dim isUnique As Boolean
    
    ReDim uniqueValues(1 To 1)
    uniqueValues(1) = rng.Cells(1, 1).Value
    
    For i = 2 To rng.Cells.Count
        cellValue = rng.Cells(i, 1).Value
        If Not IsEmpty(cellValue) Then
            isUnique = True
            For j = 1 To UBound(uniqueValues)
                If uniqueValues(j) = cellValue Then
                    isUnique = False
                    Exit For
                End If
            Next j
            
            If isUnique Then
                ReDim Preserve uniqueValues(1 To UBound(uniqueValues) + 1)
                uniqueValues(UBound(uniqueValues)) = cellValue
            End If
        End If
    Next i
    
    getUniqueValues = uniqueValues
    
End Function

I hope this will achieve your goal. Feel free to contact us again with any other inquiries or concerns.

Regards
Lutfor Rahman Shimanto

Thank you once again for your trust in us, CAR. Please do not hesitate to reach out if you need further assistance.

Regards
Team ExcelDemy

Dear ABDUL KADAR

Greetings from our website! Thank you for posting your question on the platform. As requested, I can assist you with an Excel formula using the IF and COUNTIFS functions that determine how many products a Region makes even if regardless of the product name (sometimes the product column is blank against a Region).

FORMULA:

=COUNTIFS(C5:C12, B15, D5:D12, IF(C15<>“”, C15, “”))

Regards
Lutfor Rahman Shimanto

Hello Ruby,

Greetings from our website. You have encountered a warning message from the Microsoft Excel window. The error message “You’ve entered too few arguments for this function” means not providing enough arguments or inputs for a particular formula or function to work correctly. To resolve this error, check the formula or function you’re using and ensure you’ve provided all the required arguments.

This article explains how we can highlight cells with more than three duplicates. But, if you need help understanding this post, you can follow another article on the ExcelDemy website link given below.
How to Do Conditional Formatting in Excel [Ultimate Guide]

Later go through this article to better understand and highlight if there are more than three duplicates. Good luck.

Regards
Lutfor Rahman Shimanto

Hello Patrick,

Thank you for reaching out with your issue. You encountered a Run-time error. The “Run-time error ‘9’: Subscript out of range” error occurs because you did not modify the VBA code and forgot to insert the intended sheet name. You are misled somehow by the first step of the third method. The post says to go to the Insert tab and choose Headers and Footer from the Text group, and then execute the code mentioned in the third method; that’s all.

I can provide three Excel VBA codes to avoid the error you experienced unintentionally. All you need to do is choose the intended sheet as the active sheet and run a sub-procedure from the below list.

First Method: Insert Page Number in Footer Using Excel VBA

Sub AddPageNumberInFooter()

    ActiveWindow.View = xlPageLayoutView
    ActiveSheet.PageSetup.CenterFooter = "Page &P"

End Sub

Second Method: VBA to Insert Total Page Number in Footer

Sub AddPageNumberWithTotalInFooter()

    ActiveWindow.View = xlPageLayoutView
    ActiveSheet.PageSetup.CenterFooter = "&P / &N"

End Sub

Third Method: Insert Page Number in Selected Cell

Sub PageNumberSelectedCell()
    
    Dim mVCount As Integer
    Dim mHCount As Integer
    Dim mVBreak As VPageBreak
    Dim mHBreak As HPageBreak
    Dim mNumPage As Integer
    
    mHCount = 1
    mVCount = 1
    
    ActiveWindow.View = xlPageLayoutView
    
    If ActiveSheet.PageSetup.Order = xlDownThenOver Then
        mHCount = ActiveSheet.HPageBreaks.Count + 1
    Else
        mVCount = ActiveSheet.VPageBreaks.Count + 1
    End If
    
    mNumPage = 1
    
    For Each mVBreak In ActiveSheet.VPageBreaks
        If mVBreak.Location.Column > ActiveCell.Column Then Exit For
        mNumPage = mNumPage + mHCount
    Next
    
    For Each mHBreak In ActiveSheet.HPageBreaks
        If mHBreak.Location.Row > ActiveCell.Row Then Exit For
        mNumPage = mNumPage + mVCount
    Next
    
    ActiveCell = "Page " & mNumPage & " of " & Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")

End Sub

Regards
Lutfor Rahman Shimanto (ExcelDemy Team)

Hello KEVIN

Greetings from our website! Thank you for posting your question on the platform. I have yet to experience the issue you described personally. However, I can offer some insights to help you troubleshoot the problem.

The circular reference error may occur because the formula references the cell containing the procedure, creating an infinite loop. To avoid this, you can modify the system to refer to a different cell that doesn’t have the formula.

Excel’s built-in Error Checking feature can help identify and resolve circular references. To access this feature, go to the Formulas tab in the Excel ribbon, click Error Checking, and then click Circular References. Excel will then highlight any circular references in your workbook and suggest resolving them.

Providing any prominent solution without glancing at the workbook is challenging. You can share your workbook with us via Exceldemy Forum to better understand your situation.

Regards
Lutfor Rahman Shimanto (ExcelDemy Team)

Hello AYESHA
Thanks for your query. I have analyzed the workbook Rafiul Haq shared. A prominent approach to avoid data overlapping is to create the employee record separately for each month. So don’t hesitate to make the Employee Leave description for each month.
Regards
Lutfor Rahman Shimanto

Hello ERIC SCHOENTHALER,
Thank you for your nice words! Great that you found our website and information helpful and relevant to your goal. I’m glad we could provide you with the information you were looking for. Regarding your question, you can use the following VBA code to insert a specific amount of page breaks starting at a particular line.
Regards
Lutfor Rahman Shimanto

Sub SpecificAmountOfPageBreaksWithStartingLine()
Dim Lastrow As Long
Dim Mysheet As Worksheet
Set Mysheet = Application.ActiveSheet
Row = Application.InputBox("Enter Amount of Row Number", TitleId, "", Type:=1)
NumBreaks = Application.InputBox("Enter The Number of Page Breaks", TitleId, "", Type:=1)
StartPoint = Application.InputBox("Enter The Starting Line Number", TitleId, "", Type:=1)
Mysheet.ResetAllPageBreaks
Lastrow = Mysheet.Range("B1").SpecialCells(xlCellTypeLastCell).Row
For i = StartPoint To Lastrow Step Row
If i <= StartPoint + (Row * (NumBreaks - 1)) Then
Mysheet.HPageBreaks.Add Before:=Mysheet.Cells(i, 1)
End If
Next
End Sub