Excel VBA Macro for Cell Formatting

[EnderLexus]

Hi there,
I was wondering if anyone could help me with for a macro in order to format a table that is used fairly regularly.
At the moment I can paste in a list of item numbers, and with a nifty collection, it will give me some further info on if we have that/where it might be.
My issue that I have at the moment is that it is not formatted at all, which is fine with 10/20 items but when its in the 100's its a bit tedious to do manually every time. And I'm struggling to write up any code that could format it the way that I'm trying to do, have looked around google a few times but doesn't seem to quite work for what I was aiming for especially with the spacing. ( See attached for comparisons of what I have at the moment vs what I am trying to do )
If anyone is able to help out by potentially pointing me in the right direction to get started it would be really appreciated!

 

[Marius44]

HI
I think you can do it with VBA and finally Sort based on the column you are interested in.
A peculiar thing is the empty line between the articles.

Hi
Mario

 

[EnderLexus]

HI
I think you can do it with VBA and finally Sort based on the column you are interested in.
A peculiar thing is the empty line between the articles.

Hi
Mario

Okay no problems, On an old sheet we used to use which is now broken, it would do the first blank in-between the ones that couldn't be found vs what had been found but that was a singular space in the whole table. But I'm not sure how they did it

 

[kevin9999]

What you're asking for is certainly doable, but could you please post your original sheet using the XL2BB add in, or alternatively share your file via Google Drive, Dropbox or similar file sharing platform? We can't copy from an image.

 

[kevin9999]

Try the following on a copy of your workbook. Change the sheet name & cell colour to suit. It assumes your sheet is laid out exactly as it appears in your image - headers in row 3, Column B is the first data column.

Option Explicit
Sub Fix_Format()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, r As Range
    Set ws = Worksheets("Sheet1")   '<-- *** Change to actual sheet name ***
    Set r = ws.Range("B3", ws.Cells(Rows.Count, "F").End(xlUp))
    
    '1. Sort the columns
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("D3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("B3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("C3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("E3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("F3"), Order:=xlAscending
        .SetRange r
        .Header = xlYes
        .Apply
    End With
    
    '2. Insert blank rows
    Dim a, i As Long, j As Long
    a = r
    For i = r.Rows.Count + 2 To 5 Step -1
        For j = 1 To UBound(a, 2)
            If a(i - 2, j) <> a(i - 3, j) And a(i - 2, 3) <> "Not Found" Then
                ws.Rows(i).Insert
                Exit For
            End If
        Next j
    Next i
    
    '3. Add red interior cell colour
    Dim LRow As Long
    LRow = ws.Cells(Rows.Count, "D").End(xlUp).Row
    ws.Range("B4:F" & LRow).Interior.Color = xlNone
    For i = LRow To 4 Step -1
        If ws.Cells(i, 4) = "Not Found" Then
            With ws.Range(ws.Cells(i, 2), ws.Cells(i, 6)).Interior
                .Color = 8420607            '<-- *** Change cell colour to suit ***
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[EnderLexus]

Try the following on a copy of your workbook. Change the sheet name & cell colour to suit. It assumes your sheet is laid out exactly as it appears in your image - headers in row 3, Column B is the first data column.

Option Explicit
Sub Fix_Format()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, r As Range
    Set ws = Worksheets("Sheet1")   '<-- *** Change to actual sheet name ***
    Set r = ws.Range("B3", ws.Cells(Rows.Count, "F").End(xlUp))
   
    '1. Sort the columns
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("D3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("B3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("C3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("E3"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("F3"), Order:=xlAscending
        .SetRange r
        .Header = xlYes
        .Apply
    End With
   
    '2. Insert blank rows
    Dim a, i As Long, j As Long
    a = r
    For i = r.Rows.Count + 2 To 5 Step -1
        For j = 1 To UBound(a, 2)
            If a(i - 2, j) <> a(i - 3, j) And a(i - 2, 3) <> "Not Found" Then
                ws.Rows(i).Insert
                Exit For
            End If
        Next j
    Next i
   
    '3. Add red interior cell colour
    Dim LRow As Long
    LRow = ws.Cells(Rows.Count, "D").End(xlUp).Row
    ws.Range("B4:F" & LRow).Interior.Color = xlNone
    For i = LRow To 4 Step -1
        If ws.Cells(i, 4) = "Not Found" Then
            With ws.Range(ws.Cells(i, 2), ws.Cells(i, 6)).Interior
                .Color = 8420607            '<-- *** Change cell colour to suit ***
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

I have tried this on a copy of the workbook, and seemed to work like an absolute charm. Is very much appreciated!!

 

[kevin9999]

Happy to help, and thanks for the feedback