CODEWITHSUNDEEP
excelvbaif-statementborderconditional-statements
contenrico
contenrico

Reputation: 21

Macro (VBA) in Excel to add borders and merge cells if the cells are not empty

I recorded the following Macro:

Sub Macro1()
Range("E66:F68").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("D66:D68,C66:C68,B66:B68,A66:A68").Select
Range("A66").Activate
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.Merge
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("G73").Select
End Sub

Now, this was recorded for the range starting at E66, and it basically adds borders for the cells selected and merges the cell rows in the adjacent columns. What I'd like to do is add a condition that looks at column E and starts the macro on the first non-empty cell that has no borders and ends it on the last non-empty cell. In the macro I recorded, the first unbordered non-empty cell was E66 (meaning that the cells in the range E1:E65 had all borders on at least one side), and the last non-empty cell was E68 (the range on the second line is E66:F68 because I used outside borders for the rectangle of cells from E66 to F68, but the condition only needs to be verified for column E).

In other words, I need some sort of loop that goes from E1 to Ex, and when it finds a cell that is both non-empty and unbordered, it stores that cell number as the starting cell (say Ey). Then, when it finds an empty cell (say Ez), the loop stops and the cell before Ez (so Ez-1) is stored as the last one. Then the macro that I recorded should run in the range Ey:Fz-1.

How can I do this? Thanks.

Upvotes: 1

Views: 1100

Answers (1)

Fixer
Fixer

Reputation: 74

This might work. You can adjust the filters and formatting to suit your needs. Be careful about macro-recording, though.

Sub FindAreas()
    TopRange = 1
    LastRow = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    For A = 1 To LastRow
        If Range("A" & A).Value <> "" _
            And Range("A" & A).Borders(xlEdgeLeft).LineStyle = xlNone _
            And Range("A" & A).Borders(xlEdgeRight).LineStyle = xlNone _
            And Range("A" & A).Borders(xlEdgeTop).LineStyle = xlNone _
            And Range("A" & A).Borders(xlEdgeBottom).LineStyle = xlNone _
                Then Contiguous = True Else Contiguous = False
        If A = LastRow Then
            Contiguous = False
            A = A + 1
        End If
        Select Case Contiguous
            Case False
                Call ApplyFormattingtoArea("A" & TopRange & ":A" & A - 1)
                TopRange = A + 1
                A = A + 1
        End Select
    Next A
End Sub

Sub ApplyFormattingtoArea(AppliedArea)
    Application.DisplayAlerts = False
    Range(AppliedArea).Merge
    Range(AppliedArea).Borders(xlInsideVertical).LineStyle = xlNone
    Range(AppliedArea).Borders(xlInsideHorizontal).LineStyle = xlNone
    With Range(AppliedArea)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Range(AppliedArea).Borders(xlDiagonalDown).LineStyle = xlNone
    Range(AppliedArea).Borders(xlDiagonalUp).LineStyle = xlNone
    With Range(AppliedArea).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range(AppliedArea).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range(AppliedArea).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Range(AppliedArea).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Application.DisplayAlerts = True
End Sub

Upvotes: 0

Related Questions