Hej,
So I am trying to use VBA to add conditonal formatting to compensate for some other coding, which changes the ranges from time to time. My problem is, that I only the conditional formatting to apply to xlEdgeRight and xlEdgeLeft. However, VBA always tells me that it cannot set the border style. Any ideas?
Dim rngMark As Range
Dim DateCond As FormatCondition
Dim BordNum As Long
Call wsDef
Set rngMark = wksS.Range("E11:CPB25")
rngMark.FormatConditions.Delete
Set DateCond = rngMark.FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(TODAY()>=E$7,TODAY()<F$7)")
DateCond.SetFirstPriority
With DateCond
.StopIfTrue = False
.Font.ThemeColor = xlThemeColorAccent2
.Font.Bold = True
.Borders.LineStyle = xlNone
.Borders.LineStyle = xlNone
End With
For BordNum = 7 To 8
With DateCond.Borders(BordNum)
.LineStyle = xlContinuous
.TintAndShade = 0
.Color = -16776961
.Weight = xlThin
End With
Next BordNum
Programming formatconditions - especially borders - is a bit special.
You have to use xlLeft = -4131 and xlRight = -4152 in this case:
Dim BordNum As Long
Dim arrBordNum(1) As Long
arrBordNum(0) = -4131 'xlleft
arrBordNum(1) = -4152 'xlright
For BordNum = 0 To UBound(arrBordNum)
With DateCond.Borders(arrBordNum(BordNum))
.LineStyle = xlContinuous
.TintAndShade = 0
.Color = -16776961
.Weight = xlThin
End With
Next BordNum
Related
I have some code that should formating cells with a border around (FormatConditions), but I get an error that the object isn´t supported
"VBA Object Doesn’t Support this Property or Method Error (Error 438)"
Can anybody help? I think it depends on MeinBereich.FormatConditions.Borders(xlEdgeLeft)
Private Sub Workbook_Open()
Dim my_month As String
my_month = Format(Date, "mmmm") + " " + Format(Date, "yy")
Sheets(my_month).Activate
Range("A1").Select
LR = Cells(Rows.Count, 1).End(xlUp).Row
Dim DatumColumn As Range
Dim foundRng As Range
my_day = Format(Date, "dd") + "."
Set foundRng = Range("B2:AF2").Find(my_day)
Dim MeinBereich As Range
Set MeinBereich = Range(Cells(foundRng.Row, foundRng.Column), Cells(LR, foundRng.Column))
MeinBereich.FormatConditions.Delete
Dim intErgebnis As Integer
intErgebnis = StrComp(foundRng, my_day, vbTextCompare)
If intErgebnis = 1 Then
With MeinBereich
.FormatConditions.Add Type:=xlExpression, Formula1:="=100"
With MeinBereich.FormatConditions.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
With MeinBereich.FormatConditions.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
With MeinBereich.FormatConditions.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
With MeinBereich.FormatConditions.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
End With
End If
End Sub
Format conditions and borders are a bit tricky - within VBA and GUI as well:
The basic concept:
Dim fc As FormatCondition
With MeinBereich
.FormatConditions.Delete
Set fc = .FormatConditions.Add(Type:=xlExpression, Formula1:="=100")
With fc.Borders(xlBottom)
.Color = -16776961
End With
End With
Assign the added format condition to a variable. Then you work with this to set the formatting.
You only have Borders xlBottom, xlTop, xlLeft, xlRight.
You can't set/don't need to set line style nor weight. It is always coninous and light.
As said: that's the same within GUI. If you want a bold line via format condition, you have to go the "reverse" way. Format the whole range with a normal bold border - and set it to "no border" based on the contrary condition (e.g. <> 100).
I am new to Excel VBA and want to create VBA code to use conditional formatting the cell containing "x" only to place the borders for the cell.
I want to do the exact same thing with VBA code:
APPLIES TO EVERY SINGLE CELLS IN THE WORKBOOK.
APPLIES TO EVERY SINGLE CELLS IN THE WORKBOOK.
APPLIES TO EVERY SINGLE CELLS IN THE WORKBOOK.
This is my strategy for doing so, don't know if it is correct:
First I want to select all the cell in all worksheets containing only "x".
Then change the border of all the selected cells to "All borders".
However I got many errors in the code and I cannot fix it.
Here is my code:
Sub Test()
Dim ws As Worksheet
Dim SelectCells As Range
Dim xcell As Object
Dim i As Long
Dim Last As Long
For Each ws In ThisWorkbook.Worksheets
ws.Activate
For Each xcell In ws.UsedRange.Cells
If xcell.Value = "x" Then
If SelectCells Is Nothing Then
Set SelectCells = Range(xcell.Address)
Else
Set SelectCells = Union(SelectCells, Range(xcell.Address))
End If
End If
Next
SelectCells.Select
SelectCells.Borders(xlDiagonalDown).LineStyle = xlNone
SelectCells.Borders(xlDiagonalUp).LineStyle = xlNone
With SelectCells.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With SelectCells.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With SelectCells.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With SelectCells.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With SelectCells.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With SelectCells.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Next
End Sub
So I wrote a makro, which inserts a new Column in every worksheet except the first. It works just fine. My only problem is, that I would like it to jump back to the sheet I started at after finishing up the last worksheet. All solutions I found online said, that the line: Sheets("Name of Sheet").Select should do the deed. However it doesn't do it for me. What am I doing wrong? I would also appreciate suggestions to improve the code.
Option Explicit
Sub NeueSpalte()
Dim ende As Boolean
Dim Name As Variant
Dim Anzahl_WS As Integer
Dim Zaehler As Integer
Do While ende = False
Name = InputBox("Name der neuen Spalte")
If StrPtr(Name) = 0 Then
MsgBox ("Abgebrochen!")
Exit Sub
ElseIf Name = "" Then
MsgBox ("Bitte etwas eingeben")
Else
Exit Do
End If
Loop
Anzahl_WS = ActiveWorkbook.Worksheets.Count - 1
Sheets("Rechte auf Verträge der A3").Select
Application.ScreenUpdating = False
For Zaehler = 1 To Anzahl_WS
Cells(1, 2).EntireColumn.Copy
Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Activate
ActiveCell.EntireColumn.Insert
Application.CutCopyMode = False
Cells(1, Columns.Count).End(xlToLeft).Activate
ActiveCell.EntireColumn.Select
Selection.ClearContents
Cells(8, 2).MergeCells = False
Cells(1, Columns.Count).End(xlToLeft).Offset(7, 1).Activate
Range(Cells(8, 2), ActiveCell).MergeCells = True
Cells(8, 2).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 = 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
Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Name
If ActiveSheet.Name = "Rechte auf Verträge der WW" Then
Exit Sub
Else
ActiveSheet.Next.Select
End If
Next Zaehler
Application.ScreenUpdating = True
Sheets("Rechte auf Verträge der A3").Select
End Sub
expected result: copy column b into first empty column, delete its contents and insert the user picked name in row 1 of the new column. Do that for every sheet and jump back to sheet number 2
actual result: it does everything just fine, but doesn't jump to sheet 2
I figured it out. The problem was at the end of my for loop, inside the if branching I wrote 'Exit Sub', if it is at the last sheet. I just put the 'Sheets("Rechte auf Verträge der A3").Select' before the 'Exit Sub'
A small example:
Option Explicit
Sub Select_Sheet()
'Declare the variable
Dim ws1 As Worksheet
'Set the variable
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
'Create a with statement to avoid repetition
With ws1
'Refer to range A1
.Range ("A1")
'Refer to the value of range A1
.Range("A1").Value
End With
End Sub
Please note that when you create a With Statement ranges used should have a dot "." before the rannge .Range("A1").Value
I don't believe this is very difficult but I can't figure it out...
In column B, I have either "Original" or "Add" listed. Starting from B79 and moving upwards, the first time "Original" is displayed I want to draw a border from B#:N# on the bottom.
I don't know how to run proper loops within VBA so below is what I have so far which is missing quite a bit.
Sub Test()
Range("B79").Select
If Range("B79") = "Original" Then
Selection.End(xlToRight).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlDot
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Else: ActiveCell.Offset(-1, 0).Select
End If
End Sub
Here is my current attempt. I am just trying to get it to highlight the cells.
Sub Test()
Let x = 79
Do While x > 7
If ("B" & x) = "Original" > 0 Then
Selection.End(xlToRight).Select
Else: x = x - 1
End If
Loop
End Sub
Use a for next loop and don't select, this should do what you need. Make sure you read this code and understand how it relates back to your original code.
Sub Test()
Dim X As Long
For X = 79 To 1 Step -1 'Step -1 makes it go backwards
If Range("B" & X).Text = "Original" Then 'Notice I am not actually selecting anything in this code, I don't need to in order to manipulate it
With Range("B" & X).End(xlToRight)
For Each Border In .Borders 'Loop the borders so you don't have to name each one
Border.LineStyle = xlNone
Next
With .Borders(xlEdgeTop)
.LineStyle = xlDot
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End With
End If
Next
End Sub
I'm trying to automatically border any filled cells from P13:S. When the macro runs, I also want it to detect clear cells and remove any borders currently in place. I'm using this at the moment:
Set CD = Workbooks("Savant").Worksheets("Client Details")
Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = CD.UsedRange.Rows.Count
lngLstCol = CD.UsedRange.Columns.Count
For Each rngCell In Range(Range("P13:S13"), Cells(lngLstRow, lngLstCol))
If rngCell.Value <> "" Then
rngCell.Select
With Selection.Borders
.LineStyle = xlNone
End With
End If
Next
For Each rngCell In Range(Range("P13:S13"), Cells(lngLstRow, lngLstCol))
If rngCell.Value > "" Then
rngCell.Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
Next
Application.ScreenUpdating = True
It's bordering cells as required, but it's failing to remove the borders from empty cells. Can anyone point out where I've gone wrong?
Many thanks
You can simplify your code a bit more by combining your logic so that you dont have to loop a second time.
For Each rngCell In Range(Range("P13:S13"), Cells(lngLstRow, lngLstCol))
With rngCell
If Len(Trim(.Value2)) = 0 Then
With .Borders
.LineStyle = xlNone
End With
Else
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
End With
Next
I was just being thick. Replaced the "<>" with a "=" and it works as intended. Sorry all.