PDA

View Full Version : [SOLVED] Delete Columns then add border and highlights



Rishek
06-21-2017, 09:03 PM
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
06-22-2017, 09:37 AM
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
06-22-2017, 11:12 AM
Thank you. This helps me understand how to format this kind of thing and how it fits together. Appreciated.

Rishek
06-23-2017, 04:14 PM
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
06-24-2017, 04:26 AM
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
06-24-2017, 02:01 PM
Cheers!