IF i enter number its gives error, if i enter string it still gives error. I know such a simple issue can be solved by if else but I just was trying this and now I can't get the logic why this is happening even chatgpt couldn't help me

Sub errorpractice() Dim num As Integer

On Error GoTo Badentry

num = InputBox("Enter value below 10")
Debug.Print TypeName(num)

Badentry: MsgBox "Enter only number"

End Sub

Hi, I'm running into a problem with two Excel-Workbooks and their visibility. At my work we have an Excel-Tool, that is not allowed to be used by everyone and should always be up to date for every user. For performance reasons, the workbook is copied to a local file location. Let's call the Tool "Workbook A". To keep Workbook A up to date for everyone there is a "Workbook B", which first of all checks if the user has permission to open it and then will check if the user has a local version installed and if it's the newest version. If not it will copy the newest version, which is located on a network drive, to the local C: drive.

Now to my problem: Workbook B does its things and opens the local Workbook A, which then automatically runs its Workbook_Open() sub. Workbook A always immediately opens a Userform on Workbook_Open(), which lets the user control the tool. In the Userform_Initialize() sub the application is hidden ("Application.Visible = False"). Now Workbook B is supposed to close.

If the Userform is set to "ShowModal = True", it will prevent Workbook B from closing and cause indexing errors, when I want to access cell values from Workbook A via "Sheets("SheetName").Range("A1") for example. If I set the Userform to "ShowModal = False", the Userform will become invisible, when Workbook B closes via WorkbookB.Close().

What I have tried so far:

• Setting Application.Visible = True after closing Workbook B
• Using WorkbookA.Activate before accessing Workbook A's cell values

Is there a way to close Workbook B without having it affect the visibility of the Userform in Workbook A? Unfortunately I won't be able to share the explicit files, due to security reasons. If more information is needed, I'll give it if possible.

Hey! I am trying to fix a program that I wrote and the main issue I am having is that the code seems redundant. What is the best way to adjust this code to be easier. Explanation is that the code is trying to optimize hourly bid pairs based on schedule and HSOC.

For i = 1 To scheduleRange.Rows.Count scheduleMW = scheduleRange.Cells(i, 1).Value LMP = LMPRange.Cells(i, 1).Value

    If scheduleMW = 0 And HSOC > 0 Then
        MW1 = -nMW
        BID1 = -150
    ElseIf scheduleMW = 0 And HSOC = 0 Then
        MW1 = -nMW
        BID1 = -150
    ElseIf scheduleMW > 0 And HSOC > 0 Then
        MW1 = 0
        BID1 = DISUSD * LMP
    'ElseIf scheduleMW = -nMW And HSOC = 0 Then
     '   MW1 = -nMW
      '  BID1 = CHGUSD * LMP
    'ElseIf scheduleMW > -nMW And HSOC = 0 Then
     '   MW1 = -nMW
     '   BID1 = -150 'take this out is wrong
    'ElseIf scheduleMW > -nMW And HSOC > 0 Then
     '   MW1 = -nMW
      '  BID1 = -150 'take this out if wrong
    ElseIf scheduleMW > 0 And HSOC = 0 Then
        MW1 = 999999
        BID1 = 999999
    ElseIf scheduleMW = 0 And HSOC > 0 Then
        MW1 = 0
        BID1 = OTMP
    ElseIf scheduleMW < 0 And HSOC = DIS Then
        MW = 999999
        BID = 999999
    End If

EDIT: I don’t know why my nested ifs did not like the bounded variable but select case seems to be working better.

I created buttons for my macro using Excel Shapes. What I want to achieve is to give the user an indication of the status of the module in question via the colour of the button:

https://imgur.com/a/ibAmTIK

The button can take on two colours, this being blue and red (if its red it becomes blue and vice versa upon being clicked). As you can see the buttons on the right are fully filled (this is what I want), while the buttons on the left just have the shading on top and the bottom. All buttons use the same code. And the only application of colour takes place via the following two lines of code:

ActiveSheet.Shapes(Application.Caller).Fill.BackColor.RGB = RGB(0, 112, 192) 'Blue

ActiveSheet.Shapes(Application.Caller).Fill.ForeColor.RGB = RGB(0, 112, 192) 'Blue

Given the inconsistency in the performance, I assume the objects in question might be different from one another OR have some kind of option enabled / disabled. Any ideas?

Just started working in this office and the way they do things is so slow and tedious.

So I was wondering if I could do this.

We manually search from a list of patient Unique IDs from a spreadsheet and query it on our website to pull name, DOB, email, and phone, but it’s really slow copying and pasting all this data.

I’ve had a look at the website and the profile URL is in the HTML code, and I want VBA to automate this and pull their information to populate a selected patient on the spreadsheet . I tried using the basic method using Internet Explorer— but it didn’t work. What’s the best way to do this in VBA? Is there Any better tools or libraries?

I’m a new member to this VBA coding. I’m trying to automate my mailing process . Can anyone help with with a handbook ?

Hello everyone. I have resisted VBA and most coding for near on 35years in IT. I know enuf to do some fiddling, but I'd rather have a screwdriver in my hand than a keyboard & mouse.

Microsoft® Outlook® 2021 MSO (Version 2412 Build 16.0.18324.20092) 64-bit

I'm trying to write a VBA Outlook Macro to take an email in a folder "\Inbox\SPAM*", make it an attachment to a new email, address that new email, send it, wait 15 seconds, then take the next email in that same folder "SPAM" and repeat the script, until no more emails are left in the SPAM folder.

I have tried and I can not seem to do this with just a RULE due to: I need to "Wait 15 seconds" between each send operation, because TMC can't fix their own system that calls me a spammer by reporting SPAM as fast as they send it to me. It creates a "\SMTP Error 451: Throttled due to Sender Policy" error from the server if you report more than 4 emails in 1 minute to their SPAM submission email address! You are then BLOCKED for 10Mins from sending any further emails to any address, at all!

Here is the code I have so far that does the core of the script. Could I please ask for some help to:

Add the Sleep for 15 seconds:

After running the script, change Current Item to the next email in the folder, and Loop until all emails are sent & deleted.

Sub SPAM()
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
' .
' Takes currently highlighted e-mail, sends it as an attachment to
' spamfilter and then deletes the message.
' .

    Set objItem = GetCurrentItem()
    Set objMsg = Application.CreateItem(olMailItem)
' .
    With objMsg
       .Attachments.Add objItem, olEmbeddeditem
       .Subject = "Suspicious email"
       .To = "isspam@abuse.themessaging.co"
       .Send
   End With
   objItem.Delete
' .
   Set objItem = Nothing
   Set objMsg = Nothing
End Sub
' .
Function GetCurrentItem() As Object
    On Error Resume Next
    Select Case TypeName(Application.ActiveWindow)
    Case "Explorer"
        Set GetCurrentItem = Application.ActiveExplorer.Selection.Item(1)
    Case "Inspector"
        Set GetCurrentItem = Application.ActiveInspector.CurrentItem
    Case Else
        ' anything else will result in an error, which is
        ' why we have the error handler above
    End Select
' .
    Set objApp = Nothing
End Function

Hello everyone,

I'm wondering if there is a platform like LeetCode for VBA. I want to get better, but I'm more comfortable with project-based learning or exercises.

Thanks in advance!

Saturday, January 25 - Friday, January 31, 2025

###Top 5 Posts

###Top 5 Comments

Hi, I'm having trouble getting data to copy/paste correctly from one sheet to another.

Here is the code

Sub ApplyFormulasFilterSortCopyAndPasteCOE()
Dim ws As Worksheet
Dim coeWs As Worksheet
Dim lastRow As Long
Dim copyRange As Range

' Set the worksheet to the currently active sheet
Set ws = ActiveSheet

' Set the "COE" worksheet
Set coeWs = ThisWorkbook.Sheets("COE")

' Delete columns B and D
ws.Columns("B").Delete
ws.Columns("D").Delete

' Find the last row with data in column B
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

' Loop through each cell in column B and apply the LEFT formula to column A
Dim i As Long
For i = 1 To lastRow
    ws.Cells(i, 1).Formula = "=LEFT(B" & i & ", 2)"
Next i

' Find the last row with data in column D
lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

' Loop through each cell in column D and apply the VLOOKUP formula to column O
For i = 1 To lastRow
    ws.Cells(i, 15).Formula = "=VLOOKUP(D" & i & ",Library!A:B,2,FALSE)"
Next i

' Apply filter to columns A through O
ws.Range("A1:O1").AutoFilter

' Delete rows with "SE" or "SM" in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For i = lastRow To 1 Step -1
    If ws.Cells(i, 1).Value = "SE" Or ws.Cells(i, 1).Value = "SM" Then
        ws.Rows(i).Delete
    End If
Next i

' Sort the entire dataset by column L (oldest to newest)
ws.Range("A1:O" & lastRow).Sort Key1:=ws.Range("L1"), Order1:=xlAscending, Header:=xlYes

' Copy the VLOOKUP column and paste special values on top of the same column
ws.Range("O1:O" & lastRow).Copy
ws.Range("O1:O" & lastRow).PasteSpecial Paste:=xlPasteValues

' Sort column O alphabetically
ws.Range("A1:O" & lastRow).Sort Key1:=ws.Range("O1"), Order1:=xlAscending, Header:=xlYes

' Filter out values except "coe" in column O
ws.Range("A1:O1").AutoFilter Field:=15, Criteria1:="coe"

' Find the last row after filtering
lastRow = ws.Cells(ws.Rows.Count, "O").End(xlUp).Row

' Copy the remaining data in columns B through N (excluding row 1)
Set copyRange = ws.Range("B2:N" & lastRow).SpecialCells(xlCellTypeVisible)

' Paste the copied range to the "COE" sheet starting at cell B2
coeWs.Range("B2").Resize(copyRange.Rows.Count, copyRange.Columns.Count).Value = copyRange.Value

MsgBox "Data copied to COE sheet successfully!"

End Sub

Hi! I'm trying to figure out if I can use VBA to auto populate different languages when I type in the English version for recurring schedules. For example, When I write "Every Friday" I'd like it to then be able to auto populate my translated words for both the "every" and the "weekday" (separately because this will be used for all different days of the week) in my four languages.

This would need to work for other schedules like "every other Wednesday" or "1st Monday".

I already have the translated copy for all of these words/phrases but it is a manual and repetitive process to plug it all in. The translated copy is in an excel "cheat sheet" that we use to manually copy/paste into the word document. Is this something VBA can help with? I'm struggling to figure this out. Thanks in advance!

I managed to add window buttons for minimize and maximize. But it minimizes to a small bar to the left of the screen. I can´t figure out how to make it look like an application with it´s own icon in the taskbar when minimized.

I call this from userform. And have set constants and API commands. I´m sure it´s just something I´ve missed?

Dim IStyle As LongPtr

Dim hwnd As LongPtr

hwnd = FindWindow(vbNullString, "REGISTERSÖK")

IStyle = GetWindowLongPtr(hwnd, GWL_STYLE)

IStyle = IStyle Or WS_SYSMENU

IStyle = IStyle Or WS_MAXIMIZEBOX

IStyle = IStyle Or WS_MINIMIZEBOX

Call SetWindowLongPtr(hwnd, GWL_STYLE, IStyle)

IStyle = GetWindowLongPtr(hwnd, GWL_EXSTYLE)

IStyle = IStyle Or WS_EX_APPWINDOW

SetWindowLongPtr hwnd, GWL_EXSTYLE, IStyle

DrawMenuBar hwnd

Hello,

I have a "gallery" in a custom ribbon which is intended to work similarly to the inbuild Symbols button in the Insert-tab but with some key phases and combination of symbols (like cubic meter from m and #179). My problem is that, as far as I can tell, macros cannot be run while editing a cell so I have to click the button to insert m3 before starting to type or exit the cell to paste it into another cell and manually copy it.
When I look at the inbuilt ribbon menus it is clear that some buttons are disabled as soon as you start editing a cell (with some still enabled if you start with a "="-symbol) while most are disabled.

Does anyone know how to make a macro which can paste symbols into the cell the user is currently editing?

Hello everyone,

for the automation of an Excel file, I need to access a separate Excel file in a VBA function. Unfortunately, this is not working. I have attached a small code snippet. The message box in the last line is not executed. Both the path and the name of the sheet are correct in the original and have been simplified for this post.

Does anyone have an idea why the workbook and sheet cannot be opened correctly?

Thank you very much! :)

Public Function Test(ByVal Dummy As String) As Double
Dim Sheet As Worksheet
Dim SheetName As String
Dim Book As Workbook
Dim Location As String
Dim summe As Doube
Location = "Path"
SheetName = "Table"
Set Book = Workbooks.Open(Location)
Set Sheet = Book.Sheets(SheetName)

MsgBox "here"

I wrote some code to clean up an imported file for a lab, on the test workbook it works. I created an .xlam file with it and installed the add-in on the same computer and another test computer when I tried to run the macro from the .xlam no formatting changes were made. If I copy the code into a new module inside of the test workbook the desired formatting changes happen. As I am not that experienced with vba I am assuming that I have made some type of error so that the macro isn't calling on the first sheet of the new workbooks.

Sub FixFormatting(control As IRibbonControl)

Dim ws As Worksheet

Set ws = ThisWorkbook.Sheets(1) ' Assuming the data is in the first sheet

Application.ScreenUpdating = False ' Disable screen updating for performance

Application.Calculation = xlCalculationManual ' Disable automatic calculations

' 1. Change column C's title into "record_ID"

ws.Cells(1, 3).Value = "record_ID"

' 2. Change column EH's title into "city"

ws.Cells(1, ws.Columns("EH").Column).Value = "city"

' 3. Change column EI's title into "state"

ws.Cells(1, ws.Columns("EI").Column).Value = "state"

' 4. Change column EJ's title into "zipcode"

ws.Cells(1, ws.Columns("EJ").Column).Value = "zipcode"

' 5. Split column G into two columns and name them as "user_registered_date" and "user_registered_time"

ws.Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

ws.Cells(1, 7).Value = "user_registered_date"

ws.Cells(1, 8).Value = "user_registered_time"

' 6. Take the time from column user_register_date formatted as 0:00 and place it in column user_register_time

Dim lastRow As Long

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

Dim i As Long

For i = 2 To lastRow

If IsDate(ws.Cells(i, 7).Value) Then

ws.Cells(i, 8).Value = TimeValue(ws.Cells(i, 7).Value)

ws.Cells(i, 7).Value = DateValue(ws.Cells(i, 7).Value)

End If

Next i

' 7. Reorder columns

Dim ColumnOrder As Variant, ndx As Integer

Dim Found As Range, counter As Integer

ColumnOrder = Array("record_id", "user_registered_date", "user_registered_time", "level", "title_ui", "first_name", "last_name", "middle_name", "user_login", "phone_number", "mobile_number", "user_email", "address", "city", "state", "zipcode", "country", "organization", "highest_ed", "field_of_study", "career_type", "other_career_type", "reason", "speak_vi", "speak_vi_viet")

counter = 1

For ndx = LBound(ColumnOrder) To UBound(ColumnOrder)

Set Found = ws.Rows("1:1").Find(ColumnOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

If Not Found Is Nothing Then

If Found.Column <> counter Then

Found.EntireColumn.Cut

ws.Columns(counter).Insert Shift:=xlToRight

Application.CutCopyMode = False

End If

counter = counter + 1

End If

Next ndx

' 8. Change any column's titles with capitalize first letter to no-capitalized first letter

Dim cell As Range

For Each cell In ws.Range("A1:Z1") ' Adjust the range as needed

cell.Value = LCase(Left(cell.Value, 1)) & Mid(cell.Value, 2)

Next cell

' 9. Extract all instances excluding first and numbers non-contiguous

Dim rng As Range

Dim startPos As Long, endPos As Long

Dim extractedText As String

Dim result As String

Dim firstInstanceSkipped As Boolean

' Define non-contiguous columns (e.g., columns E, S, U, X, Y)

Set rng = Union(ws.Range("E2:E1000"), ws.Range("S2:S1000"), ws.Range("U2:U1000"), ws.Range("X2:X1000"), ws.Range("Y2:Y1000")) ' Adjust ranges as needed

' Loop through each cell in the union range

For Each cell In rng

If Not IsEmpty(cell.Value) Then

result = "" ' Reset the result string for each cell

firstInstanceSkipped = False ' Reset the flag for each cell

startPos = 1 ' Start searching from the beginning of the string

' Loop through the cell's content to find all instances of : and ;

Do

' Find the next colon (:)

startPos = InStr(startPos, cell.Value, ":")

' Find the next semicolon (;) after the colon

endPos = InStr(startPos + 1, cell.Value, ";")

' If both delimiters are found

If startPos > 0 And endPos > 0 Then

' Skip the first instance

If firstInstanceSkipped Then

' Extract the text between : and ;

extractedText = Mid(cell.Value, startPos + 1, endPos - startPos - 1)

' Remove numbers, quotation marks, and colons from the extracted text

extractedText = RemoveNumbers(extractedText)

extractedText = RemoveSpecialChars(extractedText)

' Append the extracted text to the result (separated by a delimiter, e.g., ", ")

If extractedText <> "" Then

If result <> "" Then result = result & ", "

result = result & Trim(extractedText)

End If

Else

' Mark the first instance as skipped

firstInstanceSkipped = True

End If

' Move the start position to continue searching

startPos = endPos + 1

Else

Exit Do ' Exit the loop if no more pairs are found

End If

Loop

' Replace the cell content with the collected results

cell.Value = result

End If

Next cell

' 10. Split date and time and move date to column B

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

Dim dateTimeValue As String

Dim datePart As String

Dim timePart As String

Dim splitValues As Variant

' Loop through each cell in Column C (starting from C2)

For i = 2 To lastRow

' Check if the cell is not empty

If Not IsEmpty(ws.Cells(i, "C").Value) Then

' Get the date and time value from Column C

dateTimeValue = ws.Cells(i, "C").Value

' Split the date and time using space as the delimiter

splitValues = Split(dateTimeValue, " ")

' Extract the date part (first part of the split)

If UBound(splitValues) >= 0 Then

datePart = splitValues(0)

End If

' Extract the time part (second and third parts of the split)

If UBound(splitValues) >= 2 Then

timePart = splitValues(1) & " " & splitValues(2)

End If

' Move the date part to Column B

ws.Cells(i, "B").Value = datePart

' Update the time part in Column C

ws.Cells(i, "C").Value = timePart

End If

Next i

' AutoFit Columns B and C to fit the new values

ws.Columns("B:C").AutoFit

' 11. Clear column Z to FZ and highlight headers

ws.Columns("Z:EZ").ClearContents

ws.Range("A1:Y1").Interior.Color = vbYellow

' 12. AutoFit all columns to adjust their width based on content

ws.Columns.AutoFit

Application.ScreenUpdating = True ' Re-enable screen updating

Application.Calculation = xlCalculationAutomatic ' Re-enable automatic calculations

MsgBox "Data formatting complete!"

End Sub

' Function to remove numbers from a string

Function RemoveNumbers(inputText As String) As String

Dim i As Long

Dim outputText As String

outputText = ""

' Loop through each character in the input text

For i = 1 To Len(inputText)

' If the character is not a number, add it to the output text

If Not IsNumeric(Mid(inputText, i, 1)) Then

outputText = outputText & Mid(inputText, i, 1)

End If

Next i

RemoveNumbers = outputText

End Function

' Function to remove special characters (quotes and colons)

Function RemoveSpecialChars(inputText As String) As String

Dim outputText As String

outputText = Replace(inputText, """", "") ' Remove double quotes

outputText = Replace(outputText, "'", "") ' Remove single quotes

outputText = Replace(outputText, ":", "") ' Remove colons

RemoveSpecialChars = outputText

End Function

My excel sheet has 2 columns of data that I want to use. A contains a set of courts, eg. 1,2,3 and B contains a set of games eg. *Team(1) vs Team(6),Team(12) vs Team(14),Team(5) vs Team(8),*Team(1) vs Team(14),Team(12) vs Team(5),Team(6) vs Team(8)

The macro has 2 main purposes.

1. Take all the data in each cell in B and colour the first half blue and the second half red. This works fine down the column.

2. Take the data in column B, compare the specific match to the court it would be playing on listed in A (the courts are doubled into a string to allow for 2 games per night on each court) and then if the game occurs on and unideal court (currently linked to cells G1 and H1 colours that game purple for unideal1 (G1) and green for unideal2 (H1).

The code is working fine for row 1 and I have it printing out the unideal games in C1:F1 as a debugging tool, but I can't get it to do it for all rows. I think the issue is because it's not moving down the A column as it moves down the B column meaning that it's not finding any more correct matches.

My VBA knowledge is very limited - learning it for this project - and I have looked at so many functions (including trying to set strGames and strCourts as variants so they can use the range B1:B10) and things on the Microsoft site as well as stack exchange and generative AI's to try and help me find a solution and everything either doesn't seem to do what I want it to do or is so complicated I can't work out what it's trying to do.

full macro code:

Sub FormatTextHalfAndHalf()
    Dim cell As Range
    Dim firstHalf As String
    Dim secondHalf As String
    Dim length As Long
    Dim strGames As String
    Dim strCourts1 As String
    Dim strCourts2 As String
    Dim strCourts As String
    Dim Allocation1 As String
    Dim Unideal1 As String
    Dim Unideal2 As String
    Dim Game() As String
    Dim Court() As String
    Dim i As Long
    Dim j As Long
    Dim Unideal1Count As Long
    Dim Unideal2Count As Long
    Dim U1G1 As String
    Dim U1G2 As String
    Dim U2G1 As String
    Dim U2G2 As String
    Dim startPos As Long
    Dim textLength As Long
    
    
    'sets unideal court numbers from cell entry
    Unideal1 = Worksheets("Sheet1").Range("G1")
    Unideal2 = Worksheets("Sheet1").Range("H1")
    
    'sets games from cell entry
    strGames = Worksheets("Sheet1").Range("B1")
    
    'sets court numbers from cell entry
    strCourts1 = Worksheets("Sheet1").Range("A1")
    
    'takes all courts and then doubles it for games 1 and 2
    strCourts2 = strCourts1
    strCourts = strCourts1 & "," & strCourts2
    
    'splits all games into individual games
    Game = Split(strGames, ",")
    
    'splits all courts into individual courts
    Court = Split(strCourts, ",")
    
    'prints who plays on Unideal1 in games 1 and 2 in C1 and D1
    For i = LBound(Court) To UBound(Court)
    If Court(i) = Unideal1 Then
            ' Increment match count
            Unideal1Count = Unideal1Count + 1
            
            ' Store the match in the appropriate cell (C1 for 1st match, D1 for 2nd match, etc.)
            If Unideal1Count = 1 Then
                U1G1 = Game(i)
                Worksheets("sheet1").Range("C1").Value = U1G1
                
            ElseIf Unideal1Count = 2 Then
               U1G2 = Game(i)
                Worksheets("sheet1").Range("D1").Value = U1G2
                
            End If
            
            ' Exit after finding 2 matches (you can modify this if you want to keep looking for more)
            If Unideal1Count = 2 Then Exit For
    End If
   
    Next i
    
    'prints who plays on Unideal2 in games 1 and 2 in E1 and F1
    For j = LBound(Court) To UBound(Court)
    If Court(j) = Unideal2 Then
            ' Increment match count
            Unideal2Count = Unideal2Count + 1
            
            ' Store the match in the appropriate cell (C1 for 1st match, D1 for 2nd match, etc.)
            If Unideal2Count = 1 Then
                U2G1 = Game(j)
                Worksheets("sheet1").Range("E1").Value = U2G1
                
            ElseIf Unideal2Count = 2 Then
                U2G2 = Game(j)
                Worksheets("sheet1").Range("F1").Value = U2G2
                
            End If
            
            ' Exit after finding 2 matches (you can modify this if you want to keep looking for more)
            If Unideal2Count = 2 Then Exit For
    End If
    Next j
        
    
        
        
        
        
    'makes collumn B colour split in half
    ' Loop through each selected cell
    For Each cell In Range("B1:B10")
        If Not cell.HasFormula Then
            length = Len(cell.Value)
            firstHalf = Left(cell.Value, length \ 2)
            secondHalf = Mid(cell.Value, length \ 2 + 1, length)
            
            ' Clear any existing formatting
            cell.ClearFormats
            
            ' Format the first half (blue)
            cell.Characters(1, Len(firstHalf)).Font.Color = RGB(0, 0, 255)
            
            ' Format the second half (red)
            cell.Characters(Len(firstHalf) + 1, Len(secondHalf)).Font.Color = RGB(255, 0, 0)
        End If
        
        'Highlighs U1G1 game in Purple
        
        If InStr(cell.Value, U1G1) > 0 Then
        startPos = InStr(cell.Value, U1G1)
        textLength = Len(U1G1)
        
        cell.Characters(startPos, textLength).Font.Color = RGB(128, 0, 128)
        End If
        
        'Highlighs U1G2 game in Purple
        
        If InStr(cell.Value, U1G2) > 0 Then
        startPos = InStr(cell.Value, U1G2)
        textLength = Len(U1G2)
        
        cell.Characters(startPos, textLength).Font.Color = RGB(128, 0, 128)
        End If
        
        'Highlighs U2G1 game in Green
       
        If InStr(cell.Value, U2G1) > 0 Then
        startPos = InStr(cell.Value, U2G1)
        textLength = Len(U2G1)
        
        cell.Characters(startPos, textLength).Font.Color = RGB(0, 128, 0)
        End If
        
        'Highlighs U2G2 game in Purple
        
        If InStr(cell.Value, U2G2) > 0 Then
        startPos = InStr(cell.Value, U2G2)
        textLength = Len(U2G2)
        
        cell.Characters(startPos, textLength).Font.Color = RGB(0, 128, 0)
        End If
    Next cell
    
    
            
            



    
End Sub

Hey folks!

I have an access based database that I've been supporting since 2019. And recently new laptops are now being released with the latest version of Windows and the Microsoft suite is in 64-bit.

I don't know if this is the cause (Learned VBA as I go, not an expert by any means), but it's the only difference I can find in testing on different computers. (Mainly the 32 to 64-bit change)

I have a line that says the following:

Set list = CreateObject ("System.Collections.ArrayList")

For some reason, whenever the code reaches the line it will think and "load" forever, eventually saying "Not Responding" without me clicking on it or anything else on the computer. Over 10-15 minutes will go by when it normally takes a maximum of 5 minutes for the whole sub to run.

Any advice would be greatly appreciated!

Fuller bit of code is as follows:

Dim n As Long Dim lbox As ListBox, list As Object Set list = CreateObject ("System.Collections.ArrayList") For n = Me.ListSRIs.ListCount - 1 To 0 Step -1 If Not list.Contains(Me.listSRIs.ItemData(n)) Then list.Add Me.listSRIs.ItemData(n) Me.listSRIs.RemoveItem n Next List.Sort For n = 0 To list.Count - 1 Me.listSRIs.AddItem list(n) Next

There is more to the sub than the above, but I've been able to isolate this as the "relevant" portion.

I had this nagging issue - I have a program which eventually saves a file to a server location. Example

.SaveAs ":O/example.xlsx"

However, it sometimes would get stuck on the saveas progress bar which pops up, requiring clicking cancel for it to finish, even with application.displayalerts set to false. It still saved so it was more a nuisance than a big deal, but users were confused and getting annoyed so I started digging. I found the solution eventually but didn't find the solution on reddit, so I figured I'd share it here for anyone in the future searching for it that needs it. All that is needed is to wrap the SaveAs code with DoEvents. I'm not sure what makes it work, but if you ever encounter it this can save you some headaches

DoEvents
.SaveAs ":O/example.xlsx"
DoEvents

'Sup my fellow "VBA isn't programming" myth crushers! I have a new hire I brought on for the sole purpose of delegating some of the tasks I do every day. We run a proprietary software product (C++ / SQL), but which uses customized VBA to dramatically extend its core capabilities.

I have examples for him, but I'm looking for a basic, entry level course / video / training program on VBA in general. Simple stuff... structure, best practices, variables, subs, functions, etc. Single module, no UI, so doesn't really have to cover classes or forms or anything.

He's pretty young, not a classically trained programmer, but has some exposure to python and R, so I'm hoping general programming concepts should be picked up pretty easy.

As always any help appreciated!

Lets say I want to do something like this:

function test111(dim sComp as string)
test1111 = 1 sComp 2 'e.g. 1 = 2 or 1 < 2 etc...
end function

Is that possible in any manner? Maybe I just don’t know the correct syntax. In Excel itself one would use the formula INDIRECT for this kinda of operation.

SOLUTION:

I had to use the "EVALUATE" statement.

I have a VBA Script to replace text-strings in a table. Currenty it has one row for each different translation, currently it looks like this:

    usedRange.replaceAll("x", "y", criteria);
    usedRange.replaceAll("z", "w", criteria);

I'm wondering if I could create JSON with a "translation table" that it could reference for each value instead? Or maybe just have a hidden worksheet in the excel-file.

I (think I) need to do it with a script because the file generates the worksheet from Power Automate and the script automatically runs this script on the last worksheet. Otherwise I could probably do it easier with some formatting in Excel.

The code is:

Rows ("1:15").Select Application.CutCopyMode = False Selection.Delete Shift: =xlUp Range ("A:A,H:H,I:I,O:O").Select Range ("O1").Activate Selection.Delete Shift:=xlToLeft

The last line produces an error that reads "cannot use that command on overlapping sections". Literally all i did was create a macro then run it again on a new sheet to test if it worked the way i wanted it to, why would this even produce an error if I just recorded it? Any help as to how I could circumvent this "error"?

Hey everyone, I'm not too experienced with VBA and I'm trying to figure out how to change the input in cell D1 for each person listed in the range B2:B5. After that, I want to paste the output (E10) into cell C2. Then repeat for each person, (i.e the macro would move on to bob in B3 and paste his output (E10) in C3, i am assuming a do loop would be perfect for this where the n=count of b2:b5 and every iteration is N-1 until N=0. I just am not sure how to write the syntax in VBA).

The actual sheet I’m working with contains over 200 people, so doing this manually for each individual would be quite time-consuming. I appreciate any help! Thanks in advance

Hi! I need help with essentially a vlookup in Word with two seperate documents. I am not the most familiar with vba. Basically, I have 2 word documents with a table in each. They look the exact same but their rows are in different orders. I will call these targetTable and sourceTable. I want to lookup each cell in the targetTable in column 3, find it's match in column 3 of SourceTable. When I find the match, I want to copy the bullet points from that row in column 6 back to the original targetTable column 6. I have been going in circles on this, please help! I keep getting "Not Found" and I am not sure what I am doing wrong. Thank you so much! :)

Sub VLookupBetweenDocs()
    Dim sourceDoc As Document
    Dim targetDoc As Document
    Dim targetTable As table
    Dim sourceTable As table
    Dim searchValue As String
    Dim matchValue As String
    Dim result As Range
    Dim found As Boolean
    Dim i As Integer, j As Integer

    ' Open the documents
    Set targetDoc = Documents.Open("C:... TargetDoc.docm")
    Set sourceDoc = Documents.Open("C:...SourceDoc.docx")

    Set targetTable = targetDoc.Tables(1)
    Set sourceTable = sourceDoc.Tables(1)

    ' Loop through each row in table1
    For i = 3 To targetTable.Rows.Count ' I have 2 rows of headers
        searchValue = targetTable.Cell(i, 3).Range.Text ' Value to search
        searchValue = Left(searchValue, Len(searchValue) - 2)
        
        found = False
        
        
        For j = 3 To sourceTable.Rows.Count
            matchValue = sourceTable.Cell(j, 3).Range.Text
            matchValue = Left(matchValue, Len(matchValue) - 2)
            If matchValue = searchValue Then
                Set result = sourceTable.Cell(j, 6).Range
                
                result.Copy
                
                targetTable.Cell(i, 6).Range.Paste
                
                found = True
                Exit For
            End If
        Next j

        If Not found Then
            targetTable.Cell(i, 6).Range.Text = "Not Found"
        End If
        
    Next i

    MsgBox "VLOOKUP completed!"
End Sub

Back again with another strange situation - I got the software to run and work consistently, and since it takes so long I was going to try to have it show a userform that would show the user where it was in the processing, but after adding that stuff in it actually went back to skipping over functions and not outputting the correct answers. I feel like the answer to this question may lay with how I'm using DoEvents, as I am new to using that and could be using it completely incorrectly.

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

... blah blah ...
openForm 'will show this function after
updateForm "Reading File..." 'same here

DoEvents
updateForm "Parsing Block Data..."

Set outputDict = genParse3(fileName, blockReport)
blockReport.Close

...

DoEvents
updateForm "Building Connections..."

...

DoEvents
updateForm "Finding Answers..."
Unload Working

UserForm Name is "Working"

Sub openForm()
  With Working
    .Show vbModeless
  End With
End Sub
Sub updateForm(val As string)
  With Working
    .tBox.value = val
    .Repaint
  End With
End Sub

Hey there,

is there a way to limit the amount of frames where a Userform will update its screen?

I am currently trying to make a game in Excel. I have a Gameloop which deletes all Controls(Label) and then recreates them with the current sprites according to the players position. That work in a decent speed too. My Problem is the Screenupdating. If you would slow down you can see how every single Control is created, which in turn is visible in form of Screen flickering. Is there a way to stop the Userform to constantly refresh itself? I tried Application.Screenupdating, but that only seems to work for the Cells. I know that VBA isnt the right tool to do this kind of stuff, but i just like to tinker and challenge myself.

All: Photosensitive epilepsy warning:

https://reddit.com/link/1ibaioo/video/ik0iejl5wofe1/player

Hi all,

I'm writing a VBA macro to remove all double, triple, etc. paragraph marks from a Word document.

This is my code:

Dim doc As Document
Dim rng As Range
Set doc = ActiveDocument
Set rng = doc.Content

'Remove double, triple, etc, paragraph marks (^p)
'List separator is dependent on language settings
'Find the correct one
Dim ListSeparator As String
ListSeparator = Application.International(wdListSeparator)

' Use the Find object to search for consecutive paragraph marks
With rng.Find
  .Text = "(^13){2" & ListSeparator & "}"
  .Replacement.Text = "^p"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With

It works fine except for consecutive paragraph marks just before tables (and at the end of the document, but this isn't important).

For instance, if the document is like that:

^p
^p
test^p
^p
^p
^p
Table
^p
^p
^p
test^p
^p
^p
^p

The result is this one:

^p
test^p
^p
^p
^p
Table
^p
test^p
^p

Is there any way to remove those paragraph marks as well?

Alternatively, I would have to cycle through all the tables in the document and check one by one if the previous characters are paragraph marks and eventually delete them. However, I am afraid that this method is too slow for documents with many tables.

Hi!

I want to do something but I dont know what can be used for that, so I need your help.

I want my procedure to run each cell and see if its yellow (vbYellow). If its yellow, I want to it to be parte of a range variable (lets call it "game") and set game as every cell with yellow color.

I created a post like this but it was deleted by mod team because I need to "do homework". Thats a bad thing, because sometimes you dont even know how and where to start. Anyway, in my original post I didnt said that in fact I did my homework. Here is my first rude attempt:

    Dim game As Range

    Dim L As Integer, C As Integer
    
    For L = 1 To 50
        For C = 1 To 50
        
            If Cells(L, C).Interior.Color = vbYellow Then
                Set game = Cells(L, C)
            End If
        Next C
    Next L

l tought that since I was not assigning game = Nothing, it was puting every yellow cell as part of Game.

Greetings. I´ve tried different methods for intercept when user tries to change column width in some columns. Reason: data is stored there which I want to keep hidden.

AI gave me a solution that sounded simple enough:
Made a new class module named ListViewHandler:

Public WithEvents lvw As MSComctlLib.ListView

Private Sub lvw_ColumnWidthChanging(ByVal ColumnHeader As MSComctlLib.ColumnHeader, Cancel As Boolean)
    Cancel = True
End Sub

And elsewehere :

Public lvwHandler As ListViewHandler

Private Sub LoadingSub()
    Set lvwHandler = New ListViewHandler
    Set lvwHandler.lvw = Me.ListView1 ' Replace ListView1 with your ListView control name
End Sub

But no game. Is this not possible in VBA?