My goal is to copy rows from Sheet("VBA") to a specific location in Sheet("COLUMBIA-TAKEDOWN"). The location is Offset(1,1) of the cell containing "P R O S P E C T S". The first part of my code works well enough however my problems begin with selecting and editing a row [Prospect.Offset(13,-1).Select]. It appears to be ignoring this line of code because the formatting lines that follow are not happening. It's not throwing out an error message.
I understand that I'm incorrectly selecting the row and therefore unable to make the formatting changes but I don't know how to correct this problem.
Application.ScreenUpdating = False
Dim Prospect As Range
Set Prospect = Sheets("COLUMBIA-TAKEDOWN").Cells.Find(what:="P R O S P E C T S")
Sheets("VBA").Visible = True
Sheets("VBA").Rows("13:25").Copy
Prospect.Offset(1, -1).Insert shift:=xlDown
Prospect.Offset(13, -1).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Prospects.Offset(1, -1).Select
Sheets("VBA").Visible = False
End Sub
The problem is that you are trying to insert rows in a cell range... they are not the same size, hence the error.
Give this a try... might need some more thinkering, but i`ve just reused your code.
Sub test()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sht As Worksheet: Set sht = wb.Sheets("Sheet1")
Dim ProspectRow As Long: ProspectRow = sht.Cells.Find(what:="P R O S P E C T S").Row + 1
wb.Sheets("VBA").Rows("13:25").Copy
sht.Rows(ProspectRow).Insert Shift:=xlDown
With sht.Rows(ProspectRow + 13).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Application.ScreenUpdating = True
End Sub
EDIT: revamped the code for critics...
EDIT2: added the formatting...
Related
I'm using Excel version 16.24 for Mac, and I did some recording of Macros to format the worksheets followed by a loop to all the other worksheets.
However, there are 2 issues I am facing at the moment.
Issue 1: If an imported sheet is blank, there will be an error as I do not know how to create a skip to the next sheet. I have to remember to delete the sheet for the code to run without errors.
Issue 2: As I run the "FormatAllSheets" code, it only expands to a restricted area as it's recorded with data I have. In the case of the following month's data, it will not format it as there is a limitation. from the recording.
Below is the code I am using currently recorded step-by-step based on only existing data, I need to have it useable for future data as well.
Sub FormatSheet()
Cells.Select
Selection.AutoFilter
Cells.EntireColumn.AutoFit
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Selection.Font.Size = 14
Selection.Font.Bold = True
Range("A2").Select
End Sub
Sub FormatAllSheets()
Dim i As Integer
i = 2
Do While i <= Worksheets.Count
Worksheets(i).Select
FormatSheet
i = i + 1
Loop
End Sub
The above work as expected but I need to improve it to make it more seamless and responsive.
All help will be very much appreciated. I'm still new to this so pardon me for asking too many silly questions. Thank you.
Your first issue needs a check to see if any data in cell and then skip if not.
Your second issue you need to find the last used column and then you can use the range and the column number to format. Note there is no need to use selection or select as it's slows down performance. I think it will be best to use .UsedRange and just format only the cells that actually have data.
Sub FormatSheet()
Dim lrow as long
Dim ws as ActiveSheet
Cells.Select
Selection.AutoFilter
Cells.EntireColumn.AutoFit
Set ws = ActiveSheet
With ws
lrow = .Range("A" & .Columns.Count).End(xlToRight).Column
End With
With Range("A" & lrow).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Selection.Font.Size = 14
Selection.Font.Bold = True
End Sub
Sub FormatAllSheets()
Dim i As Integer
i = 2
Do While i <= Worksheets.Count
Worksheets(i).Select
if Len(Trim(.Range("A1").value)) > 0 then '->change range where data is
FormatSheet
i = i + 1
else
i = i + 1
Loop
End Sub
I have a VBA code for a Rota Sheet that is activated on change of any value in the row.
I want the code to be activated upon opening the excel.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Range("B2:V11")
If Not Intersect(Target, rng) Is Nothing Then
'scan each row (month)
Dim countRow As Long
Dim i As Long
For i = 1 To rng.Rows.count
If Not Intersect(Target, rng.Rows(i)) Is Nothing Then
If WorksheetFunction.CountIf(rng.Rows(i), "V") > 0 Then
countRow = 0
Dim cel As Range
For Each cel In rng.Rows(i).Cells
If cel.Value2 = "V" Then
countRow = countRow + 1
VacationChange cel, countRow
Else
VacationChange cel, 0
End If
Next cel
End If
End If
Next i
'scan each column (day)
Dim j As Long
For j = 1 To rng.Columns.count
If Not Intersect(Target, rng.Columns(j)) Is Nothing Then
If WorksheetFunction.CountIf(rng.Columns(j), "V") > 5 Then
VacationChange rng.Columns(j).Cells(0, 1), 6
Else
VacationChange rng.Columns(j).Cells(0, 1), 0
End If
End If
Next j
End If
End Sub
Private Function VacationChange(ByVal rng As Range, ByVal count As Long)
With rng.Interior
Select Case count
Case 0
'clear cell colors
.Pattern = xlNone
.Color = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
Case 1 To 3
'blue
.Pattern = xlSolid
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
Case 4 To 5
'yellow
.Pattern = xlSolid
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
Case Else
'red
.Pattern = xlSolid
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End Select
End With
End Function
I spent efforts by trying:
1. Using below code in Workbook: which is throwing 424 error
Private Sub Workbook_Open()
Sheet1.Activate
Call Worksheet_Change(Target)
End Sub
Pasting the entire code under Workbook_Open() function which is not working
Can anyone suggest what i am missing in the code ?
Sample Output image is attached
enter image description here
The problem is that Target is an undeclared Variant in your Workbook_Open implementation. That means when it gets passed as a parameter that needs to be a Range, the implicit cast fails and results in an error 424 (Object required).
If you want to "simulate" every cell in your target range changing, you can simply loop over B2:V11 and pass it each individual cell (untested with your data, but should give the gist):
Private Sub Workbook_Open()
Sheet1.Activate
Dim cell As Range
For Each cell In Sheet1.Range("B2:V11")
'Worksheet_Change needs to be Public
Sheet1.Worksheet_Change cell
Next
End Sub
Note that this is by no means the ideal solution to what you are trying to do and is a sign that you need to refactor your code a little bit to extract the functionality that you currently have in Worksheet_Change into a free-standing procedure. If you need to run the same code from the Worksheet_Change handler, you can call that procedure.
I'm trying to create a VBA script to highlight a particular range of cells when a user inputs any value in the cell. For example my cell range will be a1:a5, if a user enters any value in any cells within the range, cells a1 till a5 will be highlighted in the desired color. I'm a new user with VBA and after searching for a while found the below code that might be useful. Looking for advice. Thanks.
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
Next i
Application.EnableEvents = True
End With
End Sub
Edit: Trying to edit the code given by teylyn to be able to remove highlight from cells if cell value is removed however I can't seem to find the solution. (The original code will highlight the cells when there is input in cells however if you remove the cell value the highlight remains there.)
If Not Intersect(Target, Range("A12:F12")) Is Nothing Then
With Range("A12:F12").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf IsEmpty(Range("A12:F12").Value) = True Then
With Range("A12:F12").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65536
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
This code does what you describe, i.e. set a fill color for range A1 to A5 when any cell in that range is edited.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A5")) Is Nothing Then
With Range("A1:A5").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End Sub
This code needs to be put in the sheet module.
Edit: If you want the highlight to disappear if none of the five cells have a value, then you can try out this variant:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim valCount As Long
If Not Intersect(Target, Range("A1:A5")) Is Nothing Then
' a cell in Range A1 to A5 has been edited
' we don't know if that edit was adding or deleting a cell, so ...
' ... we count how many cells in that range contain values
valCount = WorksheetFunction.CountA(Range("A1:A5"))
If valCount > 0 Then
' the range has values, so highlight
With Range("A1:A5").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
' the range has no values, so remove the highlight
With Range("A1:A5").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
End Sub
I have a code that does what I want it to do, but it's HUGE, as i used the macro recorder to make it. Basically, it selects a range, applies two conditional formats and goes to the next range. I can't select the whole ranges at once because the conditional format applies an AVERAGE on each range.
Here's a piece of the code:
Sub DesvPad()
Range("C3:N3").Select
Selection.FormatConditions.AddAboveAverage
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).AboveBelow = xlAboveStdDev
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
End With
Selection.FormatConditions(1).NumStdDev = 1
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.AddAboveAverage
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).AboveBelow = xlBelowStdDev
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
End With
Selection.FormatConditions(1).NumStdDev = 1
Selection.FormatConditions(1).StopIfTrue = False
MsgBox "O macro foi executado até Range(C325:N325)"
End Sub
I know it's shameful, so I'll appreciate any help!
It's not really clear what your question is but I'll guess you're asking how to make your code more "modular" "
Sub Tester()
ApplyCF Range("A1:A10")
ApplyCF Range("A11:A20")
'etc
End Sub
Sub ApplyCF(rng As Range)
'here use rng instead of "Selection"
rng.FormatConditions.AddAboveAverage '<< for example
End Sub
I think this could help:
Sub formatInMySelectedSheets() 'use this just for few sheet
'that you want to change
Dim i As Worksheet
Dim Nm(1 To 3) As String
Dim s
Dim sht As Worksheet
'Imagine the book has 10 sheets, "Sheet1" to "Sheet10"
'but you only want to go to Sheet1, Sheet4 and Sheet7
Nm(1) = "Sheet1" 'this are the sheets you want to change
Nm(2) = "Sheet4"
Nm(3) = "Sheet7"
For Each i In ActiveWorkbook.Worksheets 'the workbook with the sheets...
For s = LBound(Nm) To UBound(Nm) 'from the lowest value of the array to
'to the highest
Set sht = Sheets(Nm(s))
'here the code shows the sheet to avoid some errors
'if the sheet is hidden, Show it to me!
If sht.Visible = xlSheetVeryHidden Or sht.Visible = xlSheetHidden Then
sht.Visible = xlSheetVisible
End If
'go to the sheet
sht.Activate
DesvPad 'Calls you code
Next s
Next i
End Sub
Sub formatInEverySheet() 'Use this to do it in every sheet
'no matter what!
Dim i As Worksheet
For Each i In ActiveWorkbook.Worksheets
i.Activate
' here the code shows the sheet to avoid some errors
If i.Visible = xlSheetVeryHidden Or i.Visible = xlSheetHidden Then
i.Visible = xlSheetVisible
End If
DesvPad 'Calls you code
Next i
End Sub
I am fairly new to VBA so I was wondering if somebody can give a helping hand on something that I have been working on. It is a fairly simple concept and I believe that most of it is done apart from one functionality I can't seem to get to work.
So far, I have created a bookmark functionality in which the current selected cell or cells is highlighted and name the range as 'bookmark' the first time the VBA script is invoked. By using the VBA script the second time around the user is taken from the previously highlighted cell and the range name as well as the highlight is deleted. However, this functionality only works on one workbook and the corresponding sheets within it.
I would like to be able to use this functionality to all currently opened workbooks or perhaps all excel document within a specific folder. My code is as follows:
Sub setBookmark()
Dim rRangeCheck As Range
Dim myName As Name
On Error Resume Next
Set rRangeCheck = Range("bookmark")
On Error GoTo 0
If rRangeCheck Is Nothing Then
ThisWorkbook.Names.Add "bookmark", Selection
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
Application.Goto Range("bookmark")
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
For Each myName In ThisWorkbook.Names
If myName.NameLocal = "bookmark" Then myName.Delete
Next
End If
End Sub
Modify like that:
Dim rRangeCheck
Dim myName As Name
On Error Resume Next
rRangeCheck = ""
rRangeCheck = Application.Names("bookmark")
On Error GoTo 0
If rRangeCheck = "" Then
ActiveWorkbook.Names.Add "bookmark", Selection
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
Application.Goto Range("bookmark")
Application.Goto Range("bookmark")
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
For Each myName In ActiveWorkbook.Names
If myName.NameLocal = "bookmark" Then myName.Delete
Next
End If
The double Applicatio.Goto it's to have the selection of Workbook + the Sheets and the cell...
If you remove, only the workbook it's selected.