[Solved] Macro Help

J

JulieVDM

New member
I have a report for work that I need to format a certain way every week, and it takes a couple hours. I am hoping to have help creating a macro to make it quicker. I would need to save the macro into a personal macro workbook or be able to run it in all workbooks.

I have uploaded a copy of the report. On the Master Tab Beginning sheet is what I start with and Master Tab End sheet is what it looks like when I'm done. I copy and paste the information into a spreadsheet so I can't change the merged cells. Here are the steps I take to format it.

  • insert 3 columns after column G
  • copy M3:O3 "Chemtrade CBT Badge, Chemtrade Onsite Badge, HF Sinclair" into G3:I3
  • match the names in columns K:L to the names in columns C:D
  • copy information in columns M:N into columns G:I that matches the name. (ex. Andersen Joe M4:O6. I copy M4:O6 into G10:I12) I do this for each name in columns K:L
  • delete columns K:O
  • copy N3 into J3 "Marathon"
  • match names in columns L:M to names in columns C:D
  • copy information in column N to column J, under the correct name. Do this for each name in column L:M
  • delete columns L:N
  • copy O3:P3 into K3:L3
  • match names in columns M:N to names in columns C:D
  • copy information in O:P to columns K:L, under the correct name. Do this for each name in M:N
  • delete columns M:P
  • fill empty cells in columns E:L with "Not on File"
  • alphabetize by last names
  • select all
  • change font to Arial 12 pt.
  • select cell C3:M3
  • highlight to .499984740745262
  • change font color to white in cells C3:M3
  • types "Notes" in cell M3
  • make width of columns C:D to 15
  • make width of columns E:L 13.86
  • make row 3 height 95.25
  • auto height all other rows
special notes:
notice on Master Tab Beginning sheet columns H:L some cells are merged in groups of 3 some in groups of 2. (ex. H49:L50). For groups of 2 I match name and copy to bottom 2 cells (ex. J49:L50 copied into E185:F186, then highlight E184:F184 the same highlighted color as E185:F186)

Notice the "Not on File" is merged over 3 cells or it can be a single cell.

The names are often in different order and there is more and more names all the time. Using more rows.

Hoping someone can help me save time.
 

Attachments

Hello JulieVDM,

Based on your detailed requirements, here's a comprehensive VBA macro that automates the formatting process you've described.
Please ensure that your data starts from row 3, with headers in row 3 and data from row 4 onwards. Also, back up your workbook before running the macro, as VBA operations cannot be undone.

VBA code:

Code: 
Sub FormatWeeklyBadgeReport()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim nameToFind As String
    Dim rng As Range
    Dim cell As Range
    Dim matchRow As Long
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Set ws = ThisWorkbook.Sheets("Master Tab Beginning")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Insert 3 columns after column G
    ws.Columns("H:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    ' Copy M3:O3 to G3:I3
    ws.Range("M3:O3").Copy Destination:=ws.Range("G3")
    
    ' Find last row in column C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' Create a dictionary for names in columns K:L and their corresponding data in M:N
    For i = 4 To lastRow
        If ws.Cells(i, "K").Value <> "" Then
            dict(ws.Cells(i, "K").Value) = ws.Range("M" & i & ":N" & i).Value
        End If
        If ws.Cells(i, "L").Value <> "" Then
            dict(ws.Cells(i, "L").Value) = ws.Range("M" & i & ":N" & i).Value
        End If
    Next i
    
    ' Loop through column C to find matching names and copy data to G:I
    For i = 4 To lastRow
        nameToFind = ws.Cells(i, "C").Value
        If dict.exists(nameToFind) Then
            ws.Cells(i, "G").Value = dict(nameToFind)(1, 1)
            ws.Cells(i, "H").Value = dict(nameToFind)(1, 2)
        End If
    Next i
    
    ' Delete columns K:O
    ws.Columns("K:O").Delete
    
    ' Copy N3 to J3
    ws.Range("N3").Copy Destination:=ws.Range("J3")
    
    ' Repeat matching and copying for other columns as needed
    ' (Add additional code here following the same pattern)
    
    ' Fill empty cells in E:L with "Not on File"
    ws.Range("E4:L" & lastRow).SpecialCells(xlCellTypeBlanks).Value = "Not on File"
    
    ' Sort by last names in column C
    ws.Range("C4:M" & lastRow).Sort Key1:=ws.Range("C4"), Order1:=xlAscending, Header:=xlNo
    
    ' Set font to Arial 12 pt
    ws.Cells.Font.Name = "Arial"
    ws.Cells.Font.Size = 12
    
    ' Highlight C3:M3
    With ws.Range("C3:M3")
        .Interior.Color = RGB(128, 128, 128) ' Gray background
        .Font.Color = RGB(255, 255, 255)     ' White font
    End With
    
    ' Set column widths
    ws.Columns("C:C").ColumnWidth = 15
    ws.Columns("E:L").ColumnWidth = 13.86
    
    ' Set row heights
    ws.Rows("3:3").RowHeight = 95.25
    ws.Rows("4:" & lastRow).EntireRow.AutoFit
    
    ' Handle merged cells in H:L
    For Each cell In ws.Range("H4:L" & lastRow)
        If cell.MergeCells Then
            With cell.MergeArea
                .UnMerge
                .Value = cell.Value
            End With
        End If
    Next cell
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Formatting complete!"
End Sub

Instructions to Use the Macro:
  • Press Alt + F11 to open the VBA Editor.
  • Insert a new module by clicking Insert >> Module.
  • Paste the above code into the module window.
  • Press F5 to run the macro.
 
I tried to run the macro but had a couple problems.

first I need to be able to run it in my personal macro workbook. So I have to change from this workbook to active workbook.

But then the macro gets hung up on this line

1748204756248.png
 
Hello Julie,

The problem most likely arises from ws not being properly set, especially when running the macro from the Personal Macro Workbook, which doesn’t automatically refer to the intended worksheet in the active workbook.

ws.Range("C4:M" & lastRow).Sort Key1:=ws.Range("C4"), Order1:=xlAscending, Header:=xlNo
will fail if ws was never defined, or if lastRow wasn't set correctly for the ActiveWorkbook.

You must ensure ws is set to a valid worksheet in the ActiveWorkbook. Add this near the top of your macro. Also, make sure lastRow is defined, e.g.:

Code: 
Sub SortByLastName()
    Dim ws As Worksheet
    Dim lastRow As Long

    Set ws = ActiveWorkbook.Sheets("Sheet1") ' Replace with your actual sheet name
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    ws.Range("C4:M" & lastRow).Sort Key1:=ws.Range("C4"), Order1:=xlAscending, Header:=xlNo
End Sub
 
I added that and added to the macro for the remaining columns. I must be misunderstanding something, it's not quite working, but I'm getting close. :)

Sub FormatWeeklyBadgeReport()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim nameToFind As String
Dim rng As Range
Dim cell As Range
Dim matchRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

Sub SortByLastName()
Dim ws As Worksheet
Dim lastRow As Long

Set ws = ActiveWorkbook.Sheets("Sheet1") ' Replace with your actual sheet name
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

ws.Range("C4:M" & lastRow).Sort Key1:=ws.Range("C4"), Order1:=xlAscending, Header:=xlNo

End Sub

Set ws = ActiveWorkbook.Sheets("Master Tab Beginning")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Insert 3 columns after column G
ws.Columns("H:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

' Copy M3:O3 to G3:I3
ws.Range("M3:O3").Copy Destination:=ws.Range("G3")

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

' Create a dictionary for names in columns K:L and their corresponding data in M:N
For i = 4 To lastRow
If ws.Cells(i, "K").Value <> "" Then
dict(ws.Cells(i, "K").Value) = ws.Range("M" & i & ":N" & i).Value
End If
If ws.Cells(i, "L").Value <> "" Then
dict(ws.Cells(i, "L").Value) = ws.Range("M" & i & ":N" & i).Value
End If
Next i

' Loop through column C to find matching names and copy data to G:I
For i = 4 To lastRow
nameToFind = ws.Cells(i, "C").Value
If dict.exists(nameToFind) Then
ws.Cells(i, "G").Value = dict(nameToFind)(1, 1)
ws.Cells(i, "H").Value = dict(nameToFind)(1, 2)
End If
Next i

' Delete columns K:O
ws.Columns("K:O").Delete

' Copy N3 to J3
ws.Range("N3").Copy Destination:=ws.Range("J3")

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

' Create a dictionary for names in columns L:M and their corresponding data in N
For i = 4 To lastRow
If ws.Cells(i, "L").Value <> "" Then
dict(ws.Cells(i, "L").Value) = ws.Range("N" & i).Value
End If
If ws.Cells(i, "M").Value <> "" Then
dict(ws.Cells(i, "M").Value) = ws.Range("N" & i).Value
End If
Next i

' Loop through column C to find matching names and copy data to J
For i = 4 To lastRow
nameToFind = ws.Cells(i, "C").Value
If dict.exists(nameToFind) Then
ws.Cells(i, "J").Value = dict(nameToFind)(1, 1)
End If
Next i

' Delete columns L:N
ws.Columns("L:N").Delete

' Copy o3:p3 to k3:l3
ws.Range("o3:p3").Copy Destination:=ws.Range("k3:L3")

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

' Create a dictionary for names in columns M:N and their corresponding data in O:P
For i = 4 To lastRow
If ws.Cells(i, "M").Value <> "" Then
dict(ws.Cells(i, "M").Value) = ws.Range("O" & i & ":P" & i).Value
End If
If ws.Cells(i, "n").Value <> "" Then
dict(ws.Cells(i, "n").Value) = ws.Range("o" & i & ":p" & i).Value
End If
Next i

' Loop through column C to find matching names and copy data to K:L
For i = 4 To lastRow
nameToFind = ws.Cells(i, "C").Value
If dict.exists(nameToFind) Then
ws.Cells(i, "K").Value = dict(nameToFind)(1, 1)
ws.Cells(i, "L").Value = dict(nameToFind)(1, 2)
End If
Next i

' Delete columns M:P
ws.Columns("M:P").Delete



' Fill empty cells in E:L with "Not on File"
ws.Range("E4:L" & lastRow).SpecialCells(xlCellTypeBlanks).Value = "Not on File"

' Sort by last names in column C
ws.Range("C4:M" & lastRow).Sort Key1:=ws.Range("C4"), Order1:=xlAscending, Header:=xlNo

' Set font to Arial 12 pt
ws.Cells.Font.Name = "Arial"
ws.Cells.Font.Size = 12

' Highlight C3:M3
With ws.Range("C3:M3")
.Interior.Color = RGB(128, 128, 128) ' Gray background
.Font.Color = RGB(255, 255, 255) ' White font
End With

' Set column widths
ws.Columns("C:C").ColumnWidth = 15
ws.Columns("E:L").ColumnWidth = 13.86

' Set row heights
ws.Rows("3:3").RowHeight = 95.25
ws.Rows("4:" & lastRow).EntireRow.AutoFit

' Handle merged cells in H:L
For Each cell In ws.Range("H4:L" & lastRow)
If cell.MergeCells Then
With cell.MergeArea
.UnMerge
.Value = cell.Value
End With
End If
Next cell

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Formatting complete!"
End Sub
 
Hello Julie,

Try this updated code and let me know:

Code: 
Sub FormatWeeklyBadgeReport()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim nameToFind As String
    Dim cell As Range
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Set ws = ActiveWorkbook.Sheets("Master Tab Beginning")
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Insert 3 columns after column G
    ws.Columns("H:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    ' Copy M3:O3 to G3:I3
    ws.Range("M3:O3").Copy Destination:=ws.Range("G3")
    
    ' Find last row in column C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' Create dict for K:L → M:N
    For i = 4 To lastRow
        If ws.Cells(i, "K").Value <> "" Then dict(ws.Cells(i, "K").Value) = ws.Range("M" & i & ":N" & i).Value
        If ws.Cells(i, "L").Value <> "" Then dict(ws.Cells(i, "L").Value) = ws.Range("M" & i & ":N" & i).Value
    Next i

    ' Fill G:H
    For i = 4 To lastRow
        nameToFind = ws.Cells(i, "C").Value
        If dict.exists(nameToFind) Then
            ws.Cells(i, "G").Value = dict(nameToFind)(1, 1)
            ws.Cells(i, "H").Value = dict(nameToFind)(1, 2)
        End If
    Next i

    ws.Columns("K:O").Delete
    
    ' Copy N3 to J3
    ws.Range("N3").Copy Destination:=ws.Range("J3")
    
    ' Reset dict
    dict.RemoveAll
    
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' L:M → N
    For i = 4 To lastRow
        If ws.Cells(i, "L").Value <> "" Then dict(ws.Cells(i, "L").Value) = ws.Range("N" & i).Value
        If ws.Cells(i, "M").Value <> "" Then dict(ws.Cells(i, "M").Value) = ws.Range("N" & i).Value
    Next i

    ' Fill J
    For i = 4 To lastRow
        nameToFind = ws.Cells(i, "C").Value
        If dict.exists(nameToFind) Then ws.Cells(i, "J").Value = dict(nameToFind)
    Next i

    ws.Columns("L:N").Delete
    ws.Range("O3:P3").Copy Destination:=ws.Range("K3:L3")
    
    dict.RemoveAll
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' M:N → O:P
    For i = 4 To lastRow
        If ws.Cells(i, "M").Value <> "" Then dict(ws.Cells(i, "M").Value) = ws.Range("O" & i & ":P" & i).Value
        If ws.Cells(i, "N").Value <> "" Then dict(ws.Cells(i, "N").Value) = ws.Range("O" & i & ":P" & i).Value
    Next i

    ' Fill K:L
    For i = 4 To lastRow
        nameToFind = ws.Cells(i, "C").Value
        If dict.exists(nameToFind) Then
            ws.Cells(i, "K").Value = dict(nameToFind)(1, 1)
            ws.Cells(i, "L").Value = dict(nameToFind)(1, 2)
        End If
    Next i

    ws.Columns("M:P").Delete

    ' Fill empty cells with "Not on File"
    On Error Resume Next
    ws.Range("E4:L" & lastRow).SpecialCells(xlCellTypeBlanks).Value = "Not on File"
    On Error GoTo 0

    ' Sort
    ws.Range("C4:M" & lastRow).Sort Key1:=ws.Range("C4"), Order1:=xlAscending, Header:=xlNo
    
    ' Format
    ws.Cells.Font.Name = "Arial"
    ws.Cells.Font.Size = 12

    With ws.Range("C3:M3")
        .Interior.Color = RGB(128, 128, 128)
        .Font.Color = RGB(255, 255, 255)
    End With

    ws.Columns("C:C").ColumnWidth = 15
    ws.Columns("E:L").ColumnWidth = 13.86
    ws.Rows("3:3").RowHeight = 95.25
    ws.Rows("4:" & lastRow).EntireRow.AutoFit

    ' Unmerge H:L
    For Each cell In ws.Range("H4:L" & lastRow)
        If cell.MergeCells Then
            With cell.MergeArea
                .UnMerge
                cell.Value = .Cells(1, 1).Value
            End With
        End If
    Next cell

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Formatting complete!"
End Sub
 
You must log in or register to reply here.

Online statistics

Members online
0
Guests online
28
Total visitors
28
Totals may include hidden visitors.

Forum statistics

Threads
416
Messages
1,845
Members
901
Latest member
JORGE W: ROSERO

Share this page

Back
Top