Macro to add borders?

[alamode]

I need a macro which should do this:

1. Search cells in row D to H for example
2. Find Cells which have a certain border on the top of the cell
3. If any cells found which have a border on the top of the cell, Then apply border at the bottom of the cell only (not on the sides or on the top)
4. Else, Do nothing.

 

[jbeaucaire]

Something like this? Select your cells to check first, then:

Option Explicit

Sub SearchBorders()
'Select a range of cells, then run this
Dim cel As Range, addrng As Range

For Each cel In Selection
    If cel.Borders(xlEdgeTop).LineStyle = xlContinuous Then
        If addrng Is Nothing Then
            Set addrng = cel
        Else
            Set addrng = Union(addrng, cel)
        End If
    End If
Next cel

If Not addrng Is Nothing Then addrng.Borders(xlEdgeBottom).LineStyle = xlContinuous

End Sub

You don't want to change the borders "as you go" else it will tamper with the results of the future cell tests.

 

[alamode]

Hmm.. I'll try that out.. But i created my own code in the meantime.. its like this :

Sub Macro6()
'
' Macro6 Macro
'

'
If Selection.Borders(xlEdgeTop).Weight = xlMedium Then
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium
End With
End If
End Sub


The only problem is it works on the selected cell. How do i get it to work on each cell from coloumn L to T?

 

[jbeaucaire]

I think yours will create problems if you try to apply it to a range of cells. Use mine, edit it for your need. Then select the cells to examine and run the macro. I would just select the range of used cells, not entire columns.

 

[alamode]

Yeah but im trying to create an automated voucher. I have to create it every week and instead of creating the excel sheet manually i wanted to automate it using macros so that i could just enter the detail on one sheet and it would create the whole voucher once i click the button. So the problem is i dont know how big the voucher could get, or how small it could be so the cells arent fixed.. I need to select the whole coloumn..

Anyway thanks though ! I got it

I need more help though.. Now im trying to do this:
Search in Coloumn T for a cell which has the following format :
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With

Once this cell is found, I want it to check if there are more then 2 blanks above it. If yes, it should delete as many rows so that it has only 2 blanks above it.