Borders, cell alingment and Wrap text with VBA in Excel - excel

I would like to format copied cells to all borders, cell align top and cell align left, as well as wrap text.
For borders I tried
With rng.Borders
.LineStyle = xlContinuous
Current Macro:
Sub Copy_Data()
Dim Src As Worksheet, Dst As Worksheet
Dim LastRow As Long, r As Range
Dim CopyRange As Range
Set Src = Sheets("Template")
Set Dst = Sheets("Report")
LastRow = Src.Cells(Cells.Rows.Count, "B").Row
For Each r In Src.Range("B2:B" & LastRow)
If r.Value = "Planning" Or r.Value = "On Hold" Or r.Value = "Planning" Or r.Value = "Gathering Info" Or r.Value = "" Then
If CopyRange Is Nothing Then
Set CopyRange = r.EntireRow
Else
Set CopyRange = Union(CopyRange, r.EntireRow)
End If
End If
Next r
If Not CopyRange Is Nothing Then
CopyRange.Copy Dst.Range("A3")
End If
End Sub

If you record a macro you will get something like this
Range("A1:C10").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
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
The above code can be also be written as. Notice how we use the loop to create the borders. Check what is the value of xlEdgeLeft, xlEdgeTop, xlEdgeBottom.. etc. You will then understand how we use the loop.
Dim rng As Range
'~~> Change this to whatever range you want
Set rng = Sheet1.Range("A1:B10")
With rng
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
For k = 7 To 12
With .Borders(k)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Next
End With
Similarly for wrap text and cell alignment, simply record a macro and edit the code to suit your need :)

Related

How to summarize a dynamic range in EXCEL

I am trying to write a code that would sum up a dynamic range of numbers in two columns.
The problem I am facing is that the data I am exporting never has the same amount of rows, therefore defining a set range, as G1-G10 for example, is pointless.
I've tried several codes found on stack overflow but none seems to work.
Note: The data always starts in G1 and H1.
Ideally the summarized columns needs to be in bold format with "all borders".
Hopefully someone can help!
The code I currently have, that obviously is not going to work, is this;
Sub HGFHGH()
Range("G1:H21").Select
Range("G21").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("G1:H21").Select
Range("H21").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
Range("G21:H21").Select
Range("H21").Activate
Selection.Font.Bold = True
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
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("I20").Select
End Sub
Best regards,
Tor
You'll want to take a look on the forums for finding the last row in vba- this is a very common task that you'll learn to either memorize or know where to go to copy it in the future!
Note in my code swap out the 7 for which ever column you want the last row count to be based off of, most keep it as 1 for column A, I don't know if you have data there, so I put 7 for column G.
Dim Lrow As Integer
Lrow = Cells(Rows.Count, 7).End(xlUp).Row
Range("G1:H" & Lrow).Select
Take note of the process: I'm declaring a variable called Lrow, assigning the row count to it, and then using Lrow instead of hardcoding a row like you did. eg: H21 vs "H" & Lrow.
If you needed to enter a formula in the next blank row, you would then have something like below, where I'm totaling only column G, and putting the answer in the next row. (Lrow +1)
Range("G" & Lrow + 1) = Application.WorksheetFunction.Sum(Range("G1:G" & Lrow))
It looked quite bad as a comment so I'll write it as an answer.
The code Perry Moen gave me resulted in the summary being dynamic and working perfectly.
So now my code for summarizing the columns looks like this;
Dim Lrow As Integer
Lrow = Cells(Rows.Count, 7).End(xlUp).Row
Range("G1:H" & Lrow).Select
Range("G" & Lrow + 1) = Application.WorksheetFunction.Sum(Range("G1:G" & Lrow))
Range("H" & Lrow + 1) = Application.WorksheetFunction.Sum(Range("H1:H" & Lrow))
Now I am trying to make the result from above code formatted to be bold and with "all borders".
Range("G" & Lrow + 1 & ":H" & Lrow + 1).Select
Selection.Font.Bold = True
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
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("I20").Select
End Sub
It dawned on me that I need to "activate the cells" in order to apply the formatting. It it possible to change "Range("G21").Activate" to just "Range("G").Activate?
Thanks a lot for the help!

Loop through a worksheet and insert a row with layout when value is true

I have a code that does a loop through a worksheets, if there is a value 2 inside a cell in column S, then I want to insert a row with a specific layout. I have the code, but it takes ages to complete. I've tried replacing .select function, but because I need a specific layout, I don't know how to avoid this.
LastRowMatchC = Worksheets("Compliance").Cells(Rows.Count, 1).End(xlUp).Row
Dim rngc As Range, rc As Long
Set rngc = Range("S8:S" & LastRowMatchC)
For rc = rngc.Count To 1 Step -1
If rngc(rc).Value = 2 Then
rngc(rc + 1).EntireRow.Insert
rngc(rc + 1).EntireRow.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
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
End If
Next rch

Doing a loop from 1 to LastRow

I've written the code below to do a loop witch I have used in the past, I now however want to do switch the loop.
If a cell in column Q contains a 1 then it adds a row with a certain layout. The code now goes from Q3276 to Q8, how do I reverse the process Preferably I want the loop to go rom Q8 to Q LastRow. Also if anyone has a more lean way of writing the code please let me know.
Dim rngc As Range, rc As Long
Set rngc = Range("Q8:Q3276")
For rc = rngc.Count To 1 Step -1
If rngc(rc).Value = 1 Then
rngc(rc + 1).EntireRow.Insert
rngc(rc + 1).EntireRow.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
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("A35").Select
End If
Next rc
Preferably I want the loop to go rom Q8 to Q LastRow.
To reverse a loop, you can use For rc = 1 to rngc.Count. Note that this will complicate what you are trying to do.
Also if anyone has a more lean way of writing the code please let me know.
Avoid using Select/Selection etc
Use Autofilter. This way no loops will be required and you can work with filtered rows in ONE GO
The border constants range form 5 to 12. What I mean is that the value of xlDiagonalDown is 5 and so on till xlInsideHorizontal which has a value of 12. In such a case we can use a Loop/Select Case to format the borders/cells as shown below
I have commented the code so you should not have a problem understanding it.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
Dim filteredRange As Range
Dim i As Long
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Find last row in Col Q
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng = .Range("Q8:Q" & lRow)
'~~> Filter the range and set your filtered range
With rng
.AutoFilter Field:=1, Criteria1:="=1"
Set filteredRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Check if we have any filtered rows
If Not filteredRange Is Nothing Then
With filteredRange
'~~> Change interior color
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
'~~> Format the borders
For i = 5 To 12
Select Case i
'~~> Left, Top, Bottom, Right
Case 7 To 10
With .Borders(i)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'~~> DiagUp,DiagDown,InsideVert,InsideHorz
Case 5, 6, 11, 12
.Borders(i).LineStyle = xlNone
End Select
Next i
End With
End If
'~~> Remove filters
.AutoFilterMode = False
End With
End Sub

EXCEL VBA macro for putting a style to a range and then ucase

i'm newbie, sorry in advance for myy long question
So, i have two macros (one recorded and pasted in personal macro) and other i found in google
The first one, with my selection fills the color to orange and adds bolds borders
The second one with the selection, upercases all the range.
However, when i run this two macro together with another sub (calling the subs) the text does not shows up, i need to change of cell then select again and run the macro again in order to function.
Sub text ()
Dim rng As Range
Dim sAddr As String
Set rng = Selection
Selection.Merge
ActiveCell.FormulaR1C1 = _
"=""additional due for "" & TEXT(TODAY(),""MMMM "") & ""end of month"""
sAddr = rng.Address
rng = Evaluate("index(upper(" & sAddr & "),)")
Selection.NumberFormat = "General"
End Sub
Then the filling up sub (which is a little long)
Sub ORANGE()
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
'CAMBIO 2
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.NumberFormat = "General"
End Sub
The way i use both macros is simply calling first ORANGE and then TEXT, beacuse the other way does not works, when i try them in VBA run macro option it works fine.
When i use the button in the ribbon i need to change of cell, select it again and it will work. i use this macro a lot but it simply makes me repeat it each time.
Does anybody knows who to perform both task at once without the result being an empty orange cell?
Thanks!
Try this. Read comments inside the code:
Public Sub AddTextAndFormat()
Dim selectedRange As Range
Set selectedRange = Selection
' Merges the selection
selectedRange.Merge
' Adds the formula to the first selection's cell
selectedRange.Formula = "=""additional due for "" & TEXT(TODAY(),""MMMM "") & ""end of month"""
' Uppercase that first cell
selectedRange.Cells(1, 1).Value = UCase$(selectedRange.Cells(1, 1).Value)
' Apply formats
With selectedRange
.Font.Bold = True
' Borders:
.BorderAround LineStyle:=xlContinuous, ColorIndex:=0, Weight:=xlMedium
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
' Other format:
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
'CAMBIO 2
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
'.MergeCells = False -> This line unmerges the first cells merge
.NumberFormat = "General"
End With
With selectedRange.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub

Adding all borders to a selected range, is there a shorter way to write the code?

I am adding all borders to a certain range, In my case (A6:O6),in excel VBA, the below code works but I'd imagine there would have to be a shorter way to write it. I found a single line of code that puts a border around the whole selection but not around every cell.
Range("A6:O6").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
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
You can use the below statements
Dim myRange As Range
Set myRange = Range("A6:O6")
With myRange.Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Try this. It will add a border around every cell in the range A6:O6.
Sub Macro1()
Dim rng As Range
' Define range
Set rng = Range("A6:O6")
With rng.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 0
.TintAndShade = 0
End With
End Sub

Resources