Delete Columns then add border and highlights

[Rishek]

I have the following macro, adapted from KUTools for Excel:

Sub Macro1()
'updateby Extendoffice 20160616
    Dim xEndCol As Long
    Dim I As Long
    On Error Resume Next
    xEndCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Application.ScreenUpdating = False
    For I = xEndCol To 1 Step -1
'Here is the code I've tried to add
        If Application.WorksheetFunction.CountA(Columns(I)) <= 1 Then
            With Columns(I).Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .Weight = xlThick
                    .ColorIndex = 6
            End With




        End If
'that was the last line I added
        If Application.WorksheetFunction.CountA(Columns(I)) <= 1 Then
        Columns(I).Delete
        End If
    Next




    Application.ScreenUpdating = True
End Sub

It deletes empty columns and empty columns with headers, which is great. I would like it also to leave a think yellow border between any cells where a column has been deleted. I would also like the header cell in the column to the right of the deleted cell to be highlighted in yellow (basically, this is to leave an indication that columns have been deleted.

Thus this:

d	d	d	d	e	d	d	d	f	g
x				x				x

becomes:

d	e	f
x	x	x

Where the cells with "e" and "f" have a yellow fill and there's a thick yellow border between "d" and "e" as well as "e" and "f".

I'm also hoping to avoid ending up with a border or highlighting where column g used to be (might be a consequence of the logic I'm trying to apply).

As may be apparent, I have very little idea what I'm doing.

[p45cal]

try:

Sub Macro1()
'updateby Extendoffice 20160616
Dim xEndCol As Long
Dim I As Long

On Error Resume Next
xEndCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Application.ScreenUpdating = False
For I = xEndCol To 1 Step -1
  If Application.WorksheetFunction.CountA(Columns(I)) <= 1 Then
    With Columns(I - 1).Borders(xlEdgeRight)
      .LineStyle = xlContinuous
      .Weight = xlThick
      .ColorIndex = 6
    End With
    With Columns(I + 1).Borders(xlEdgeLeft)
      .LineStyle = xlContinuous
      .Weight = xlThick
      .ColorIndex = 6
    End With
    Columns(I + 1).Cells(1).Interior.ColorIndex = 6
    Columns(I).Delete
  End If
Next
Application.ScreenUpdating = True
End Sub

[Rishek]

Thank you. This helps me understand how to format this kind of thing and how it fits together. Appreciated.

[Rishek]

How would I limit the created border to the last filled row? I currently have big yellow lines extending into infinity (makes scaling for printing hard). Thanks!

[p45cal]

Sub Macro1()
'updateby Extendoffice 20160616
'update by p45cal vbaExpress 20170624
Dim xEndCol As Long, xEndRow As Long
Dim I As Long

On Error Resume Next
xEndCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
xEndRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
For I = xEndCol To 1 Step -1
  If Application.WorksheetFunction.CountA(Columns(I)) <= 1 Then
    With Cells(1, I - 1).Resize(xEndRow).Borders(xlEdgeRight)
      .LineStyle = xlContinuous
      .Weight = xlThick
      .ColorIndex = 6
    End With
    With Cells(1, I + 1).Resize(xEndRow).Borders(xlEdgeLeft)
      .LineStyle = xlContinuous
      .Weight = xlThick
      .ColorIndex = 6
    End With
    Columns(I + 1).Cells(1).Interior.ColorIndex = 6
    Columns(I).Delete
  End If
Next
Application.ScreenUpdating = True
End Sub

[Rishek]

Cheers!