Could you please help me with my code. A have simple data to which I want to apply "All Borders". Number of rows will change
Sub Draw_Borbers()
Dim FO As Worksheet
Dim LastRow As Long
Dim AllRange As Range
Set FO = ThisWorkbook.Worksheets("Final Order")
LastRow = FO.Cells(Rows.Count, 1).End(xlUp).Row
Set AllRange = Range("A2:I2" & LastRow)
With AllRange.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 0
.TintAndShade = 0
End With
End Sub
The problem is while I only have 361 non-empty row (based on column A), it gives me borders for 2361 rows.
I thought It is because of blanc rows and added
.Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
to previous macros, but it still gives me that odd number of rows.
In previous macros I copy-paste data from pivot table and delete some rows, but even full list consists of only 651 rows...
Would appreciate your help very much!
Related
I've found codes in other posts and other forums, but they don't seem to work for me.
I only have a basic working knowledge of VBA I can understand what it does, but creating a complex code is harder
I have a multiple worksheets A1:K##
Column C has a number or a code (text)
Starting with row B I want to add a thick bottom border every 9th row (so after 9, 18, 27 etc)
And stop when the numbers end
Restart the count for the Code(text).
Thanks in advance for any help
Here's a sample of what started with, but could not manage to properly modify it to do what I wanted.
I was able to have the whole row bottom border thick, but not just in the A to K range.
Sub Borders()
Dim cl As Range
Dim LC As Long
LC = Cells(1, Columns.Count).End(xlToLeft).Column
For Each cl In Range("$A$1:$A" & Cells(Rows.Count, "A").End(xlUp).Row)
If cl.Row Mod 10 = 0 Then
With cl.Resize(1, LC).Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
End If
Next cl
End Sub
I added the option of resetting the count at the text code, if I'm getting help may as well get it done right first.
Having re-read your question I spotted the multiple sheets part.
Your code works fine and will do on multiple sheets with a couple of minor changes.
This uses For....Each to loop through each sheet in the workbook that contains the code (ThisWorkbook).
Select Case sht.Name is used so the code only runs on specified sheets. Move the code to the Do Nothing line if it's easier to list the sheets you don't want it to run on. Remove the Select...End Select if you want it to run on all sheets.
With....End With is used to tell the range references what sheet you to look at - Cells, Rows, Columns - anything that is specific to a sheet is preceded by a . to tell the code you're referring to the sheet in the With line.
Sub Borders()
Dim cl As Range
Dim LC As Long
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
Select Case sht.Name
Case "Sheet1", "Sheet2", "Sheet4"
With sht
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Each cl In .Range("$A$1:$A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
If cl.Row Mod 9 = 0 Then
With cl.Resize(1, LC).Borders(xlEdgeBottom)
.LineStyle = xlSingle
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
End If
Next cl
End With
Case Else
'Do nothing.
End Select
Next sht
End Sub
Further reading:
For...Each
With
Select Case
These are my merged cells
I would like to loop though these merged cells, find the end of every merged cell and then Border Around on the left with Dots(xlDots) till ROW6
This would be my output
Here is what I tried until now
Dim rng As Range
Set rng = Range("A1:I6")
With rng.Borders
.LineStyle = xlDot
.Weight = xlThin
End With
But it borders me every cell, can I give a STEP 2 like in a for loop?
Here is variation on #JvdV answer.
For Each cel In ThisWorkbook.Sheets("Sheet1").Range("A3:M3") 'change sheet as needed
If cel.MergeCells = True Then
With cel.MergeArea.Offset(1).Resize(3).Borders(xlEdgeLeft)
.LineStyle = xlDash
End With
End If
Next cel
My suggestion is based of a trick seen here
Sub Test()
Dim rng As Range, cl As Range
With Sheet1 'Change appropriately
Set rng = Intersect(.Cells.SpecialCells(2), .Cells.SpecialCells(4))
For Each cl In rng
If cl.MergeArea.Row = 3 Then
cl.MergeArea.Offset(1).Resize(3, cl.MergeArea.Columns.Count).Borders(xlEdgeLeft).LineStyle = xlDot
End If
Next cl
End With
End Sub
.Intersect creates a range out of all cells that are part of merged areas through the use of .SpecialCells. I used a combination of constants and blanks (indexes 2 and 4 respectively) but if your values are a result of formulas you can change that to -4123 and 4.
I made sure these cells are part of a .MergeArea that starts at row 3.
Then simply .Offset by 1 row and .Resize that range object up to row 6 and the actual width of the merged area (using Columns.Count) since you might not be 100% sure about the width of columns of these merged areas.
You can set the xlEdgeLeft border's linestyle right there to xlDot.
Obviously, if your range of merged cells only involves column A-I it would get a lot more simple, while this solution is a bit more dynamic in that sense.
As an alternative, you don't need VBA. You can use Conditional Formatting:
Rule:
=AND(A$3<>"",B$3="",C$3="")
Applies to Range:
=$C$4:$I$6
And of course just choose the format as desired.
I want to change the background color of cells, but not the entire row, based on the value of a cell. I have some code that does what I want, but I'm sure there is a more efficient way and would like some help in making my code more efficient. Listed below is a snippet of the code that performs the task.
Sub chg_bkgrnd_Color()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim counter As Long
Set rng = Range("k2:k23")
Range("k2").Select
For Each cell In rng
Select Case cell.Value
Case Is = "Closed"
ActiveCell.Offset(counter, -10).Interior.ThemeColor = xlThemeColorDark1
ActiveCell.Offset(counter, -10).Interior.TintAndShade = -0.249977111117893
ActiveCell.Offset(counter, -9).Interior.ThemeColor = xlThemeColorDark1
ActiveCell.Offset(counter, -9).Interior.TintAndShade = -0.249977111117893
ActiveCell.Offset(counter, -8).Interior.ThemeColor = xlThemeColorDark1
ActiveCell.Offset(counter, -8).Interior.TintAndShade = -0.249977111117893
ActiveCell.Offset(counter, -7).Interior.ThemeColor = xlThemeColorDark1
ActiveCell.Offset(counter, -7).Interior.TintAndShade = -0.249977111117893
End Select
counter = counter + 1
Next
End Sub
Conditional Formatting would be best, but if you wish to use normal formatting, this is a streamlined version of your code:
Sub chg_bkgrnd_Color()
Dim i&
For i = 2 To 23
If Cells(i, 11) = "Closed" Then
With Range(Cells(i, 1), Cells(i, 4)).Interior
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
End With
End If
Next
End Sub
Following #Jeeped's suggestion, here is a version to use to automate this. In the worksheet's code module, place this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
RangeAutoBackFill "Closed", 11, 2, 23, 1, 4, xlThemeColorDark1, -0.249977111117893
End Sub
And then in a standard code module, place this:
Public Sub RangeAutoBackFill(Key$, KeyCol&, KeyRowLow&, KeyRowHigh&, FillColLow&, FillColHigh&, FillTheme&, FillTint#)
Dim i&
For i = KeyRowLow To KeyRowHigh
If Cells(i, KeyCol) = Key Then
With Range(Cells(i, FillColLow), Cells(i, FillColHigh)).Interior
.ThemeColor = FillTheme
.TintAndShade = FillTint
End With
End If
Next
End Sub
You are inquiring about how to get the cells from columns A:D to have a highlight based upon whether the corresponding value in column K is "Closed" or not. Conditional Formatting is a better solution as it provides an automated, background reaction to changes in column K instantly.
Sub Create_Conditional_Formatting_for_AD_based_on_K_Closed()
Dim v As Long, vSTATEs As Variant, vCOLOURs As Variant
vSTATEs = Array("Open", "Closed", "Pending")
vCOLOURs = Array(3, 10, 5)
With ActiveSheet.Columns("A:D")
.FormatConditions.Delete
For v = LBound(vSTATEs) To UBound(vSTATEs)
With .FormatConditions.Add(Type:=xlExpression, _
Formula1:="=$K1=" & Chr(34) & vSTATEs(v) & Chr(34))
With .Interior
.ColorIndex = vCOLOURs(v)
End With
.StopIfTrue = True
End With
Next v
End With
End Sub
This routine may be well suited to a situation where you want to apply the CF rules to a large number of worksheets or as a recurring task on a regular import to a new worksheet but it probably is more work than simply creating the six rules manually.
I've simplified the selection of a backfill colour with the .ColorIndex property. You can find a table of ColorIndex numbers and colours here.
Please note that I am deleting previous CF rules with an Applies to: of columns A:D before constructing new ones. That may be a consideration if you have other CF rules governing the behavior in columns A:D.
Using a formula in a CF rule and locking the column K reference with an absolute $ indicator allows you to implement an Applies to: that is different from the column being evaluated. Use Home ► Conditional Formatting ► Manage Rules to view the outcome.
Manual method:
Select columns A:D with A1 as the ActiveCell
Choose Home ► Conditional Formatting ► New Rule
Choose Use a formula to determine which cells to format and supply the following in the Format values where this formula is true: text box: =$K1="closed
Click format and choose an appropriate highlight combination from the Fill tab.
Click OK to accept the formatting change and then OK again to create the rule.
Go to step 2 and repeat as necessary. If you start with Home ► Conditional Formatting ► Manage Rules and choose New you can save a few clicks.
Your results should resemble the following.
I am a newbie. I've just written a code which copies a range of cells with looking the first 3 number of the number in the left adjacent column of those cells. For Ex: if the first three number of A1 and A5 is 100 than copy B1:D1 and B5:D5 to a new workbook. At the beginning I was using inputbox to enter the number (100) to find the range that I want to copy. Now I want to use multiple inputs. Like I want to copy cells that are at the right of 100 to a new workbook and cells that are right of 120 to another new workbook with just one code... I wrote a code with using listbox. However the problem is whenever I choose multiple items like 100 110 120 it doesn't work. It copies right adjacent cells of the cells that contains 100 to a new workbook, than again it copies right cells of 100 to another new workbook. I am stuck and waiting for a person to enlight me. Sorry for my english, I am not a native speaker. Anyway here is the code:
Private Sub Userform_Initialize()
With ListBox1
.AddItem "100"
.AddItem "110"
.AddItem "120"
End With
ListBox1.ListIndex = 0
End Sub
Private Sub OKButton_Click()
Dim c As Range
Dim rRng As Range
Dim LRow As Range
Dim rRng2 As Range
Dim i As Integer
ChDir "C:\Users\Loff1\Desktop\CreatedBD"
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
LedAcc = ListBox1.List(i)
For Each c In Workbooks("Test.xlsx").Sheets("TestBD").Range("A2:A100")
If LedAcc = Left(c, 3) Then
If rRng Is Nothing Then
Set rRng = c
Else
Set rRng = Application.Union(rRng, c)
End If
End If
Next
Set rRng2 = rRng.Offset(0, 3)
Workbooks("Test.xlsx").Sheets("TestBD").Select
Range(rRng, rRng2).Select
Selection.Copy
Set NewBook = Workbooks.Add
NewBook.Sheets("Sheet1").Select
Range("B9").Select
ActiveSheet.Paste
Range("A6").Value = LedAcc
ThisFile = Range("A6").Value
NewBook.SaveAs Filename:=ThisFile
Workbooks(ThisFile & ".xlsx").Close SaveChanges:=False
End If
Next i
End Sub
I think your problem is here:
Range(rRng, rRng2).Select
You probably mean to do this:
Application.Union(rRng, rRng2).Select
in my test
rRng was A1,A5,A8
rRng2 was C1,C5,C8
Range(rRng, rRng2).Select 'results to select range("A1:C1")
Application.Union(rRng, rRng2).Select 'results to select cells A1,A5,A8,C1,C5,C8
Offtopic:
let me recommend you to use With blocks and dont use select but try to refer the ranges without selecting them: How to avoid using Select in Excel VBA macros
Instead of
Workbooks("Test.xlsx").Sheets("TestBD").Select
Range(rRng, rRng2).Select
Selection.Copy
You can do
With Workbooks("Test.xlsx").Sheets("TestBD")
.Range(rRng, rRng2).Copy
End With
or
Workbooks("Test.xlsx").Sheets("TestBD").Range(rRng, rRng2).Copy
I am trying to use conditional formatting (green - yellow - red color scales) on 844 distinct rows to track premium volume over the last six years (years are columns). Here is the tricky part in between each volume column is number of items. I would like to format each row for premium volume and leave the number of items unchanged.
At this point I am selecting each individual premium volume cell by holding ctrl down and then selecting the conditional formatting.
I am trying to automate this so I don't have to continue this process for 844 rows and future spreadsheets as well.
I attached a picture of the worksheet for your reference.
Any help is greatly appreciated!!!
Thanks,
Brad
I got some basic code for the conditional formatting by running the Macro Recorder. I replaced all the occurrences of Selection with a rng variable, and set that rng variable as a parameter to the subroutine so the Sub can be called in a loop:
Sub SetRangeCF(rng As Excel.Range)
rng.FormatConditions.AddColorScale ColorScaleType:=3
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
rng.FormatConditions(1).ColorScaleCriteria(1).Type = _
xlConditionValueLowestValue
With rng.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
rng.FormatConditions(1).ColorScaleCriteria(2).Type = _
xlConditionValuePercentile
rng.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With rng.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 8711167
.TintAndShade = 0
End With
rng.FormatConditions(1).ColorScaleCriteria(3).Type = _
xlConditionValueHighestValue
With rng.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
End Sub
Then you call the sub above in a loop, in this case once for any row that has a value in column A. This assumes that the condtional formatting starts in row 2 and that you have uninterrupted data in column A. If not, you'd have to adjust this looping code:
Sub SetEachRow()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim cell As Excel.Range
Set ws = ActiveSheet 'change as necessary
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For Each cell In .Range("A1:A" & LastRow)http://stackoverflow.com/questions/10245638/excel-changes-conditional-formatting-formula?rq=1
cell.EntireRow.FormatConditions.Delete
SetRangeCF cell.EntireRow
Next cell
End With
End Sub
I don't know what the limit of rows is that this will work on, but 1,000 worked fine for me.