I would like to outline only the outside border of a very strange noncontiguous range.
Here's a working example of the stupidest (and only) way I can write this.
Sub test()
Range("A1").Borders(xlEdgeBottom).Weight = xlMedium
Range("B3").Borders(xlEdgeBottom).Weight = xlMedium
Range("C3").Borders(xlEdgeBottom).Weight = xlMedium
Range("D4").Borders(xlEdgeBottom).Weight = xlMedium
Range("A1").Borders(xlEdgeTop).Weight = xlMedium
Range("B2").Borders(xlEdgeTop).Weight = xlMedium
Range("C2").Borders(xlEdgeTop).Weight = xlMedium
Range("D3").Borders(xlEdgeTop).Weight = xlMedium
Range("A1").Borders(xlEdgeLeft).Weight = xlMedium
Range("B2").Borders(xlEdgeLeft).Weight = xlMedium
Range("B3").Borders(xlEdgeLeft).Weight = xlMedium
Range("D4").Borders(xlEdgeLeft).Weight = xlMedium
Range("A1").Borders(xlEdgeRight).Weight = xlMedium
Range("C2").Borders(xlEdgeRight).Weight = xlMedium
Range("D3").Borders(xlEdgeRight).Weight = xlMedium
Range("D4").Borders(xlEdgeRight).Weight = xlMedium
End Sub
Obviously this is not what I want to do. I would like to pass a range to this Sub.
I think I could add each cell to a Collection object (Or maybe just a Range object followed by a long string like: Range("A2, F6, K2:L4") ) and loop through the Collection, checking if neighboring cells are part of that Collection, and if not, placing a border.
Any help appreciated!
Does this suit your needs?
Does this suit your needs?
Sub Test()
DrawBorderAroundSelection Range("A1,B2:C3,D3:D4"), xlMedium
End Sub
Sub DrawBorderAroundSelection(rngShape As Range, lineweight)
For Each c In rngShape.Cells
If c.Column = c.Parent.Columns.Count Then
c.Borders(xlEdgeRight).Weight = lineweight
ElseIf Intersect(c.Offset(0, 1), rngShape) Is Nothing Then
c.Borders(xlEdgeRight).Weight = lineweight
End If
If c.Row = c.Parent.Rows.Count Then
c.Borders(xlEdgeBottom).Weight = lineweight
ElseIf Intersect(c.Offset(1, 0), rngShape) Is Nothing Then
c.Borders(xlEdgeBottom).Weight = lineweight
End If
If c.Column = 1 Then
c.Borders(xlEdgeLeft).Weight = lineweight
ElseIf Intersect(c.Offset(0, -1), rngShape) Is Nothing Then
c.Borders(xlEdgeLeft).Weight = lineweight
End If
If c.Row = 1 Then
c.Borders(xlEdgeTop).Weight = lineweight
ElseIf Intersect(c.Offset(-1, 0), rngShape) Is Nothing Then
c.Borders(xlEdgeTop).Weight = lineweight
End If
Next
End Sub
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 have a function that formats a range but it only seems to be formatting the first range I select.
I've tried selecting the range first then formatting but it lengthens my code quite a bit.
Sub Numbers()
Call format(Range(Cells(4, "A"), Cells(2 + i - j, "AA")))
Call format(Range(Cells(4, "C"), Cells(4 + i - j, "F")))
Call format(Range(Cells(4, "G"), Cells(4 + i - j, "J")))
End Sub
Sub format(R As Range)
With R
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.weight = xlMedium
End With
End With
End Sub
I want to format all the ranges but its only formatting the first one ie: only formats -> Range(Cells(4, "A"), Cells(2 + i - j, "AA"))
You could either loop through in your main sub and call the format sub x amount of times or modify the format sub to use a ParamArray. This will allow you to pass any number of ranges to the format sub in one line
Sub formatRange(ParamArray rngs() As Variant)
Dim i As Long
For i = 0 To UBound(rngs)
If TypeName(rngs(i)) = "Range" Then
With rngs(i)
Debug.Print i, .Address, TypeName(rngs(i))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
End With
End If
Next i
End Sub
Sub test()
formatRange Range("A1"), Range("A2"), Range("A3")
formatRange Range("B5"), Range("I6")
' etc. etc....
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.