Hi I find error when running this routine in VBA.
Sub interest()
Dim newRange As Range
Dim rng As Range
Dim cel As Range
Dim ws As Worksheet
Range("D9").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
For Each cel In rng.Cells
If cell.Value = "Cr" Then
cell.Offset(0, -1).Value = cell.Offset(0, -1).Value
Else
cell.Offset(0, -1).Value = cell.Offset(0, -1).Value * (-1)
Next
End Sub
You forgot an End If before Next cel
You didn't attributed anything to rng! You only selected some range of the spreadsheet.
The code could be fixed like this:
...
Range("D9").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Set rng = Selection
...
You are getting a compile error because you aren't closing the If-block with End If (See iDevlop's answer).
In VBA, you need to write If as follows:
If cell.Value = "Cr" Then
cell.Offset(0, -1).Value = cell.Offset(0, -1).Value
Else
cell.Offset(0, -1).Value = cell.Offset(0, -1).Value * (-1)
End If
Only then you can finish the For-Loop with Next.
PS: As mentioned by Ehsan in his answer, you should assign some values to rng, or you will run into the next error at rng.Cells.
Related
This is how my spreadsheet looks like:
enter image description here
I would like to insert a HLOOKUP formula to the cell immediate right of 58DV if the cell contains 58DV. If there is no data, nothing needs to be done. I'm still quite new to VBA so I'm not sure how can i work with formulas in VBA. Thanks
Sub sitelookup()
With Application
.ScreenUpdating = False
End With
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("C4:C1299")
For Each cel In SrchRng
If cel > 0 Then
cel.Offset(0,1).value = Application.WorksheetFunction.HLOOKUP(F4,'Raw G'!2:5,2,0)
End If
Next cel
End Sub
Try,
with worksheets("sheet1")
Set SrchRng = .Range(.cells(4, "B"), .cells(rows.count, "B").end(xlup))
For Each cel In SrchRng
If cel.value2 = "58DV" Then
'to put the formula's value into the neighboring cell
cel.Offset(0, 1).value = _
Application.HLOOKUP(.cells(cel.row, "F"), worksheets("Raw G").range("2:5"), 2, 0)
'to put the formula into the neighboring cell
'cel.Offset(0, 1).formula = _
"=HLOOKUP(F" & cel.row & ",'Raw G'!2:5, 2, 0)"
End If
Next cel
end with
So I am trying to write a For Each loop to look through an entire row. If it finds the word "Specialty" Copy it over to the next three cells.
It does this part fine, but then when it loops around, of course the next cell has "Specialty" in it bc it just copied it over. I need to figure out how to say, if you've found "Specialty" and copied it over, jump 4 cells over and begin searching again..... Tried Offsetting the active cell but didn't work.
Any ideas?
Thanks!
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For Each Cell In rngRow
If InStr(1, Cell.Value, "Specialty") Then
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
End If
Next Cell
End Sub
Here's how to loop backwards given your current code:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Dim cIndex As Long
Set rngRow = Range("A8:BA8")
For cIndex = rngRow.Columns.Count To rngRow.Column Step -1
Set Cell = Cells(rngRow.Row, cIndex)
If InStr(1, Cell.Value, "Specialty", vbTextCompare) Then
Cell.Offset(, 1).Resize(, 3).Value = Cell.Value
End If
Next cIndex
End Sub
You could replace 'For each' by a an integer iterable:
Sub CopySpecialtyOver()
Dim i As Integer
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For i = 1 To rngRow.Cells.Count
Set Cell = rngRow(1, i)
If InStr(1, Cell.Value, "Specialty") Then
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
i = i + 3
End If
Next i
End Sub
Thank you so much! I ended up solving it like this:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For Each Cell In rngRow
If InStr(1, Cell.Value, "Specialty") Then
If InStr(1, Cell.Offset(0, -1).Value, "Specialty") Then
Else
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
End If
End If
Next Cell
End Sub
For Each - as pointed out by other responses - may not be the best strategy. Nevertheless - as you asked for it - here comes a piece of code using some in-loop control to overcome the deficites of For Each in this use case:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Dim Found As Boolean
Dim Cnt As Integer
Set rngRow = Range("A8:BA8")
Found = False
Cnt = 0
For Each Cell In rngRow.Cells
If InStr(1, Cell.Value, "Specialty") And Not Found Then
' capture start of sequence - otherwise do nothing
Found = True
Cnt = 0
Else
If Found Then
'if in Found mode increment counter
Cnt = Cnt + 1
' expand using negative offset
If Cnt <= 3 Then
Cell = Cell.Offset(0, -Cnt).Value
End If
' break after 3rd
If Cnt = 3 Then
Found = False
Cnt = 0
End If
End If
End If
Next Cell
End Sub
This seemingly more complex code will have its advantage when run vertically (instead horizontally) over much more than just a handfull of cells, as For/Each performs much better than regular For/Next
I'm more than new at this, and I'm having trouble sorting out For...Next loops.
I want to track to two text variables in two columns, so that when both variables are found in a row text is added to that row in a different column.
This is what I have so far:
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("B1:B100")
Set Rng2 = Range("A1:A100")
For Each cel In Rng1
If InStr(1, cel.Value, "A") > 0 Then
For Each cel In Rng2
If InStr(1, cel.Value, "B") > 0 Then
cel.Offset(0, 5).Value = "AB"
End If
Next
End If
Next cel
End Sub
You might even be able to just do this?
Sub AB()
With ActiveSheet
For I = 1 To 100
If InStr(1, .Cells(I, 2), "A") > 0 And InStr(1, .Cells(I, 1), "B") > 0 Then
.Cells(I, 6).Value = "AB" 'i think offset 5 is column F?
End If
Next
End With
End Sub
Appreciate you have an answer now, but here's a different method using Find. Always good to know several ways to do something.
Sub AB()
Dim rng As Range
Dim itemaddress As String
With Columns(1)
Set rng = .Find("A", searchorder:=xlByRows, lookat:=xlWhole)
If Not rng Is Nothing Then
itemaddress = rng.Address
Do
If rng.Offset(0, 1) = "B" Then
rng.Offset(0, 2).Value = "AB"
End If
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And itemaddress <> rng.Address
End If
End With
End Sub
You're using `cel' to step through each loop - the inner loop will get confused.
Along the vein of #findwindow answer (appeared as I was typing this). Loop just once and when a match is found check the cell next to it.
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Dim cel1 As Range
'Be specific about which sheet your ranges are on.
With ThisWorkbook.Worksheets("Sheet1")
Set Rng1 = .Range("B1:B100")
Set Rng2 = .Range("A1:A100")
End With
For Each cel1 In Rng1
'Check each value in column B.
If InStr(1, cel1.Value, "A") > 0 Then
'If a match is found, check the value next to it.
If InStr(1, cel1.Offset(, -1), "B") > 0 Then
cel1.Offset(, 4).Value = "AB"
End If
End If
Next cel1
End Sub
I'm very new to Excel VBA (started about a day ago!) but I'm slowly struggling through. I've created a formula that copies a selection of three cells to another part of the sheet if column D contains the value "(2)", then assigns the value "0" to some more cells in the same row.
The trouble is, I've used a mixture of recording and typing my macro so the end result is pretty messy. Currently the macro takes a while to complete (it moves everything around and then a little hourglass appears for a good 15 seconds or so). I'm assuming this is in part due to my use of "Select" (I'm aware this is a bad thing!) but I'm just trying to work out what I can strip from the formula to make it more efficient while retaining the same outcome.
Sub MoveNames()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("D:D")
For Each cel In SrchRng
If InStr(1, cel.Value, "(2)") > 0 Then
cel.Offset(0, 1).Range("A1:C1").Select
Selection.Copy
ActiveCell.Offset(-1, 40).Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(0, -4) = "0"
ActiveCell.Offset(0, -5) = "0"
ActiveCell.Offset(0, -6) = "0"
ActiveCell.Offset(0, -7) = "0"
ActiveCell.Offset(0, -10) = "0"
ActiveCell.Offset(0, -12) = "0"
End If
Next cel
End Sub
Any help would be much appreciated.
If I understand what you're trying to do, this should do the same thing without having to use any objects or any copy/paste methods:
Sub MM_MoveNames()
For i = 2 To Cells(Rows.count, 4).End(xlUp).Row
If InStr(Cells(i, 4).value, "(2)") Then
Cells(i - 1, 44).Resize(1, 3).value = Cells(i, 5).Resize(1, 3).value
Cells(i, 37).Resize(1, 4).value = 0
Cells(i, 34).value = 0
Cells(i, 32).value = 0
End If
Next
End Sub
More importantly though - if your code is working, and you just want advice for improvements then you should post your code on Code Review, not on Stack Overflow.
try this
Sub MoveNames()
Dim SrchRng As Range
lastrow = Range("D" & Rows.Count).End(xlUp).Row
Set SrchRng = Range("D1:D" & lastrow)
For Each cel In SrchRng
If InStr(1, cel.Value, "(2)") > 0 Then
With cel.Offset(0, 1).Range("A1:C1")
.Copy cel.Offset(-1, 40).Range("A1")
End With
With cel.Offset(-1, 40)
.Offset(0, -4) = "0"
.Offset(0, -5) = "0"
.Offset(0, -6) = "0"
.Offset(0, -7) = "0"
.Offset(0, -10) = "0"
.Offset(0, -12) = "0"
End With
End If
Next cel
End Sub
Give this a shot, you can definitely clean it up more by combining the multiple offsets and ranges.
Sub test()
Dim rngIndex As Range
For Each rngIndex In Range("D:D")
If InStr(1, rngIndex.Value, "(2)") > 0 Then
rngIndex.Offset(0, 1).Range("A1:C1").Copy _
rngIndex.Offset(0, 1).Range("A1:C1").Offset(-1, 40).Range("A1")
With rngIndex.Offset(0, 1).Range("A1:C1")
Range(.Offset(0, -4), .Offset(0, -7)).Value = 0
.Offset(0, -10) = "0"
.Offset(0, -12) = "0"
End With
End If
Next rngIndex
End Sub
Instead of going throug each cell in column D, you can go through just the used range, like this:
Set SrchRng = Range("D1:D" & ActiveSheet.UsedRange.Rows.Count)
Which should speed it up quite a bit.
You can use Select, I found that easier when I was learning VBA myself. In time you will learn to avoid it.
To speed up macro execution when using Select, you can add Application.ScreenUpdating = False at the beginning and Application.ScreenUpdating = True at the end of your procedure.
Disabling automatic calculations is also beneficial, you can do it by adding Application.Calculation = xlManual and Application.Calculation = xlManual at the beginning and end respectively.
Hope that helps. if you have more questions, just ask.
My turn - instead of looking at each cell, just jump to the ones containing (2).
Sub MoveNames()
Dim SrchRng As Range, cel As Range
Dim rFound As Range
Dim sFirstAddress As String
Set SrchRng = ThisWorkbook.Worksheets("Sheet1").Range("D:D")
Set rFound = SrchRng.Find("(2)", LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlNext)
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
rFound.Offset(, 1).Resize(, 3).Copy Destination:=rFound.Offset(-1, 41)
rFound.Offset(-1, 34).Resize(, 4) = 0
rFound.Offset(-1, 29) = 0
rFound.Offset(-1, 31) = 0
Set rFound = SrchRng.FindNext(rFound)
Loop While Not rFound Is Nothing And rFound.Address <> sFirstAddress
End If
End Sub
The following code is a change event handler that searches col B for the word "fee" and inserts comments in the 3 adjacent cols if the word "fee" is found in col B:
Private Sub Worksheet_Calculate()
Dim rng As Range, cell As Range
Set rng = Range("B:B")
If Not rng Is Nothing Then
For Each cell In rng.Cells
If cell.Value = "fee" Then
cell.Offset(0, 1).AddComment "fi"
cell.Offset(0, 2).AddComment "fo"
cell.Offset(0, 3).AddComment "fum"
End If
Next
End If
End Sub
The above code works fine.
I also want to search col B and delete any existing comments in the 3 adjacent cols if the word "fee" does not occur in col B. So, I added an Else statement:
Private Sub Worksheet_Calculate()
Dim rng As Range, cell As Range
Set rng = Range("B:B")
If Not rng Is Nothing Then
For Each cell In rng.Cells
If cell.Value = "fee" Then
cell.Offset(0, 1).AddComment "fi"
cell.Offset(0, 2).AddComment "fo"
cell.Offset(0, 3).AddComment "fum"
Else:
cell.Offset(0, 1).Comment.Delete
cell.Offset(0, 2).Comment.Delete
cell.Offset(0, 3).Comment.Delete
End If
Next
End If
End Sub
This results in the runtime error: "Object variable or With block variable not set", and the debugger points to
cell.Offset(0, 1).Comment.Delete
VBA seems to want me to use a With statement, but the With permutations I've tried result in the same error. Any thoughts?
Follow up with Andy's correct suggestion. The code adds comments if the condition is met, clears comments if it is not:
Private Sub Worksheet_Calculate()
Dim rng As Range, cell As Range
Set rng = Range("B:B")
If Not rng Is Nothing Then
For Each cell In rng.Cells
cell.Offset(0, 1).ClearComments
cell.Offset(0, 2).ClearComments
cell.Offset(0, 3).ClearComments
If cell.Value = "fee" Then
cell.Offset(0, 1).AddComment "fi"
cell.Offset(0, 2).AddComment "fo"
cell.Offset(0, 3).AddComment "fum"
End If
Next
End If
End Sub
VBA is not suggesting that you use With. The error occurs if you attempt to Delete a comment when there isn't one.
You can either check for the existence of a comment before attempting to Delete it:
Dim cmt As Comment
Set cmt = Range("A1").Comment
If Not cmt Is Nothing Then
Range("A1").Comment.Delete
End If
or, simpler, use ClearComments:
Range("A1").ClearComments
Also note that your first code is on the Calculate event, not Change.
Delete the colon after Else as well - always have Else as a single word on its own line; this colon may cause issues.
Added following OPs coded solution: Your code could be simplified:
If Not rng Is Nothing Then
For Each cell In rng.Cells
cell.Offset(0, 1).ClearComments
cell.Offset(0, 2).ClearComments
cell.Offset(0, 3).ClearComments
'or even just
'cell.Range("B1:D1").ClearComments
If cell.Value = "fee" Then
cell.Offset(0, 1).AddComment "fi"
cell.Offset(0, 2).AddComment "fo"
cell.Offset(0, 3).AddComment "fum"
End If
Next
End If