This is really simple but I'm new to VBA.
I want to format cells in column J and K (haven't gotten to K yet) with a grey fill and border around if cells in column B is not empty. I want to do this in every worksheet in the workbook.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Format_ForecastingTemplate(ws)
Next
End Sub
Sub Format_ForecastingTemplate(ws As Worksheet)
Dim cell As Range
Dim N As Long
Dim i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
If cell <> "" Then
With ActiveSheet.Range(Cells("J"), cell.Row)
.ThemeColor = xlThemeColorDark1
.BorderAround LineStyle:=xlContinuous
End With
End If
Next
End Sub
The line that is giving me an error is If cell <> "" Then. I think it's because I'm not referencing the cell variable in column B?
Error is: Object variable or With block variable not set
Like this:
I changed it to a single macro and made changes to your original code
Sub Format_ForecastingTemplate()
Dim cell As Range
Dim N As Long
Dim i As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
'Looks at B to check if empty
If ws.Cells(i, 2).Value <> "" Then
'changes cells J to color and border
ws.Cells(i, 10).Borders.LineStyle = xlContinuous
ws.Cells(i, 10).Interior.ThemeColor = xlThemeColorDark1
ws.Cells(i, 10).Interior.TintAndShade = -0.25
End If
Next i
Next ws
End Sub
You can either change the column number or add new lines for column K
Hope this helps and please be kind and leave feedback. :)
Related
From Sheet1 and Sheet2, if a cell from B column has "In Progress", then I want to copy that entire row to another Sheet4.
I want to repeat it for all rows of both the sheets.
Sub Demo1()
Dim wb As Workbook
Dim ws As Worksheet, sh As Worksheet
Dim lastrow As Long
Dim w As Integer
Dim i As Integer
Set wb = Workbooks(Book1)
Set ws = Worksheets("Sheet4")
Set sh = ActiveSheet
For w = 1 To wb.Sheets.Count
For i = 1 To lastrow
If ActiveSheetCells(i, 2).Value = "In Progress" Then
wb.ws.Cells(1, 1).Insert
Else
If Cells(i, 2).Value = "" And i < 50 Then
ActiveCell.Offset(1, 0).Select
End If
Cells(i, 2).Value = "" And i > 49
Next i
Next w
End Sub
Error Message
Sheet 1
Sheet 2
Sheet 3
Quick review on your code, based on my comments to the post (untested):
Sub Demo1()
Dim wb As Workbook: Set wb = Workbooks("Book1")
Dim destinationSheet As Worksheet: Set destinationSheet = wb.Worksheets("Sheet4")
Dim sourceSheet As Worksheet: Set sourceSheet = ActiveSheet
With sourceSheet
Dim lastRowSource As Long: lastRowSource = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim w As Long, i As Long
For w = 1 To wb.Sheets.Count
For i = 1 To lastRowSource
If .Cells(i, 2).Value = "In Progress" Then
destinationSheet.Cells(1, 1).Insert
Else
If .Cells(i, 2).Value = "" And i < 50 Then
'Why are you Selecting and what are you doing with it?
.Cells(i,X).Offset(1, 0).Select 'Change from "activeCell" to an actual cell reference as you don't change the activecell when looping...
End If
Cells(i, 2).Value = "" And i > 49 'Is this supposed to be another If statement?
End If 'Added
Next i
Next w
End With
Don't use Integer, use Long; the prior gets converted within VBA so you can save the processing with using the latter.
Use descriptive variable names so you're not lost in 10 months re-looking at your code, or having someone else look at your code. For the most part, people should be able to understand what's happening without the use of excessive comments.
Do your best to not have a wall of variables. If you can dimension a variable just as it's being used, you're pairing things together and might catch that x as long when you're using it as a string a lot faster.
You have a .Select and nothing happens with that. Additionally, included as a comment, using ActiveCell is probably not what you want... use a direct cell reference. Note that when you loop, VBA will change its references, however it does not physically change its activecell.
You have what appears to be another If statement which does not include any If / Then for the i > 49 bit.
The culprit of your error is the lack of End If, which is now placed with the comment Added.
I'm a beginner. Just learning by Googleing, but cannot find a solution for this. Please help.
I want to run the below macro.
I have multiple cells named "CV_=CVCAL" in the same column.
What I want is for the macro to find the first cell with the value "CV_=CVCAL" and offset to the adjacent cell. If the adjacent cell has a particular value, if the value is below lets say "1.5" i want to fill it will a cell style 'bad'.
I want the macro to go through all the cells that have the name CV_=CVCAL and do the same thing until there is no more cells named CV_=CVCAL.
Sub If_CV()
Range("A1").Select
Set FoundItem = Range("C1:C1000").Find("CV_=CVCAL")
FoundItem.Offset(columnOffset:=1).Select
If ActiveCell.Value >= 1.5 Then
ActiveCell.Style = "Bad"
End If
End Sub
Sounds like you want to loop through your values.
Determine the end of your range
Loop through your range and check your criteria
Sub If_CV()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long
lr = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If ws.Range("C" & i) = "CV_=CVCAL" Then
If ws.Range("D" & i) >= 1.5 Then
ws.Range("D" & i) = "Bad"
End If
End If
Next i
End Sub
A basic loop would be simpler:
Sub If_CV()
Dim c As Range, ws As Worksheet
For Each ws in ActiveWorkbook.Worksheets
For Each c in ws.Range("C1:C1000").Cells
If c.Value = "CV_=CVCAL" Then
With c.offset(0, 1)
If .Value >= 1.5 Then .Style = "Bad"
End With
End If
Next ws
Next c
End Sub
I have some history working with VBA, but can't seem to find the solution to this problem. I found an iteration process to select a cell, do a process, and then select the next cell and do the process again, until NULL. I am having a problem outputting each of the processes solutions into the next column. Here is what I have:
Sub Name ()
Dim X As Integer
Dim MyString as String
Application.ScreenUpdating = False
NumRows = Range("D2", Range("D2").End(xlDown)).Rows.Count
Range("D2").Select
For X = 1 To NumRows
MyString = ActiveCell.Value
MyString = Right(MyString, Len(MyString)-6)
Range("I2 to I#").Value = MyString
ActiveCell.Offset(1,0).Select
Next X
End Sub
Range("I2 to I#").Value = MyString is the line that I need help with. I need it to increment to I3, I4, I5, etc. until it reaches NumRows count.
When working with Cells the best way to loop through them is For Each Cell in Range so taking this and as comments told you to avoid selecting, this should help you:
Option Explicit
Sub Name()
Dim C As Range, MyRange As Range
Dim LastRow As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("MySheet") 'Change MySheet for your working sheet name
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row on column D
Set MyRange = .Range("D2:D" & LastRow) 'declare your working range
For Each C In MyRange
If Not C = vbNullString Then .Cells(C.Row, "I") = Right(C, Len(C) - 6)
Next C
End With
Application.ScreenUpdating = True
End Sub
Another solution is Do Until. You could use this method if you dont have empty cells in the middle of your data.
Option Explicit
Sub Test()
Dim StartingPoint As Long
StartingPoint = 2 'Set the line to begin
With ThisWorkbook.Worksheets("Sheet1") 'Set the worksheet
Do Until .Cells(StartingPoint, "D").Value = "" 'Repeat the process until you find empty cell
.Cells(StartingPoint, "I").Value = Right(.Cells(StartingPoint, "D").Value, Len(.Cells(StartingPoint, "D").Value) - 6)
StartingPoint = StartingPoint + 1
Loop
End With
End Sub
The code below searches for duplicates in different sheets of my work book. The issue is that it takes a little while for it to be done. How can I add a progress indicator in the status bar at the bottom?
Thank you & Kind regards.
Sub dup()
Dim cell As Range
Dim cella As Range
Dim rng As Range
Dim srng As Range
Dim rng2 As Range
Dim SheetName As Variant
Application.ScreenUpdating = False
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set srng = Sheets("Screener").Range("A7:A2000")
Set rng = Sheets("Rejected").Range("A7:A2000")
Set rng2 = Sheets("Full Data").Range("A7:A2000")
For Each cell In rng
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 4
cella.Offset(, 1) = "Rejected"
End If
Next cella
Next cell
For Each cell In rng2
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 5.5
cella.Offset(, 1) = "Reported"
End If
Next cella
Next cell
Application.ScreenUpdating = True
End Sub
One thing you can do is speed up your code, there's a few things I'd change about it in its current state,
It's really slow to access range objects and their value, you should instead load the ranges into a variant array and cycle through the arrays
If you find a duplicate, you still go through and check every other range in both arrays which wastes time, you should skip to the next range once you've found a duplicate
With that in mind I've rewritten your code like this, it's completely equivalent and runs in less than a second on my machine:
Sub dup()
Dim i As Integer, j As Integer
Dim RejectVals As Variant
Dim ScreenVals As Variant
Dim FullDataVals As Variant
Dim SheetName As Variant
Dim output() As String
'Push column on 'Screener' sheet to the right to make space for new output
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Worksheets("Screener").Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Pull the values from your 3 ranges into arrays to avoid costly cycling through ranges
ScreenVals = Application.Transpose(Sheets("Screener").Range("A7:A2000").Value)
RejectVals = Application.Transpose(Sheets("Rejected").Range("A7:A2000").Value)
FullDataVals = Application.Transpose(Sheets("Full Data").Range("A7:A2000").Value)
'Resize output column to be same size as column we're screening because
'we're going to place it in the column adjacent
ReDim output(LBound(ScreenVals) To UBound(ScreenVals))
'Cycle through each value in the array we're screening
For i = LBound(ScreenVals) To UBound(ScreenVals)
'Skip without checking if the cell is blank
If ScreenVals(i) = vbNullString Then GoTo rejected
'Cycle through each value in the 'FullData' array
For j = LBound(FullDataVals) To UBound(FullDataVals)
'If it's a duplicate then
If ScreenVals(i) = FullDataVals(j) Then
'Set the relevant value in the output array to 'Reported'
output(i) = "Reported"
'Colour the cell on the 'screener' page
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 5.5
'Skip checking more values
GoTo rejected
End If
Next j
'Next cycle through all the 'Rejected' values
For j = LBound(RejectVals) To UBound(RejectVals)
'If it's a duplicate then
If ScreenVals(i) = RejectVals(j) Then
'Set the relevant value in the output array to 'Rejected'
output(i) = "Rejected"
'Colour the cell
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 4
'Skip checking any more values
GoTo rejected
End If
Next j
rejected:
Next i
'Pop the output array in the column next to the screened range
Worksheets("Screener").Range("B7:B2000") = Application.Transpose(output)
End Sub
I check for duplicates in the 'Full Data' sheet first which means if there is a duplicate in both tables then it will default to 'Reported' and a yellow cell, if you'd like the opposite you can swap the order of the loops.
Let me know if there's anything you don't understand
So I'm fairly new to VBA, and I have been struggling with trying to get my macro to work.
Essentially what I'm trying to do is have a program read down a column, and for every "X" located in that column, the corresponding hyperlink in the adjacent column will be selected.
Sub Select_Hyperlinks()
Dim rng As Range, cell As Range, sel As Range
Dim sht As Worksheet
For x = 1 To 6
Set sht = Sheets("Generator")
Set sel = cell.Offset(-1, 0)
Set rng = Intersect(sht.Range("D4:D9"), sht.UsedRange)
For Each cell In rng.Cells
If (cell.Value) <> "X" _
Then
If sel Is Nothing Then
Set sel = cell.Offset(-1, 0)
sel.Select
End If
Next cell
End If
Next x
End Sub
I also tried a simpler idea using the Find and FindNext functions and for each X, I tried to get it to select and activate the cell in the adjacent column, but also with no luck. It seems I always get snagged up on the .Offset function.
EDIT:
Here's what I've managed to come up with, after some further research. I've adapted this from a macro designed to delete all empty rows.
Sub AutoOpen()
Dim xlastcell As Integer
Dim xcell As Integer
xcell = 1
Range("C200").End(xlUp).Select
xlastcell = ActiveCell.Cells 'This used to say ActiveCell.Row but I want a single cell'
Do Until xcell = xlastcell
If Cells(xcell, 1).Value = "X" Then
Cells(x, 1).Select
ActiveCell.Offset(0, -1).Select 'I'm also unable to get this function to work'
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
xcell = xcell - 1
xlastcell = xlastcell - 1
End If
xcell = xcell + 1
Loop
End Sub
Are you saying that if there is an X in the one column, you want to open the hyperlink?
EDIT:
Use this and change things to match your variables.
Sub asdhkl()
Dim c As Hyperlink
Dim i As Range
For Each i In Sheets(1).Range("b1:b3")
If i = "x" Then
Set c = i.Offset(0, -1).Hyperlinks(1)
c.Follow
End If
Next i
End Sub