Tried to look into cells in a column and then find out if the cells has 6/7 characters and if it has i.
Then copy over.
Sub ctest()
Dim i As Long
For i = 1 To 5000
With Range("AR" & i)
If Left(.Value, 1) <> "i" Then GoTo NextIteration Else
If Len(.Value) = 6 Then .Copy Destination:=.Offset(, 2)
If Len(.Value) = 7 Then .Copy Destination:=.Offset(, 2)
NextIteration:
End With
Next i
End Sub
But this doesn't seem to work well..
Thanks guys.
If you just want to skip the loop, why don't use basic if statement
Sub ctest()
Dim i As Long
For i = 1 To 5000
With Range("AR" & i)
If Left(.Value, 1) = "i" Then
If Len(.Value) = 6 Then .Copy Destination:=.Offset(, 2)
If Len(.Value) = 7 Then .Copy Destination:=.Offset(, 2)
End If
End With
Next i
End Sub
Related
I am very new to VBA and have been stuck on this for a few days now.
I would like to compare H2 and H3. If equal then turn the cell green , If not equal then turn the cell red.
Once this is complete I would like to do the same for H4 and H5 , then H6 and H7...... all the way down to the last row of data.
Thank you in advance for your help .
How about something like this?
Sub ForLoopTest()
Dim loop_ctr As Integer
Dim Max As Integer
Max = ActiveSheet.UsedRange.Rows.Count
For loop_ctr = 1 To Max
If loop_ctr Mod 2 = 0 Then
row_below = loop_ctr + 1
If Cells(loop_ctr, "H") = Cells(row_below, "H") then
Cells(loop_ctr, "H").Interior.ColorIndex = 4
Cells(row_below, "H").Interior.ColorIndex = 4
Else
Cells(loop_ctr, "H").Interior.ColorIndex = 3
Cells(row_below, "H").Interior.ColorIndex = 3
End If
End If
Next loop_ctr
End Sub
I still feel like conditional formatting is they way to go here so that it's reactive to values changing in the worksheet, but if you are stuck on VBA as a solution here, something like this should do the trick:
Sub greenOrRed()
Dim lngRow As Long
For lngRow = 2 To Sheet1.Range("H2").End(xlDown).Row Step 2
If Sheet1.Range("H" & lngRow).Value = Sheet1.Range("H" & lngRow + 1).Value Then
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 4
Else 'didn't match
Sheet1.Range("H" & lngRow & ":H" & lngRow + 1).Interior.ColorIndex = 3
End If
Next lngRow
End Sub
You could also use a For Each loop to walk down the column which makes for some nice to read code. You just have to apply a test for Mod 2 on the row you are analyzing instead of using the very handy STEP 2 like in the For loop above:
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then
If rngCell.Value = rngCell.Offset(1).Value Then
rngCell.Resize(2).Interior.ColorIndex = 4
Else
rngCell.Resize(2).Interior.ColorIndex = 3
End If
End If
Next rngCell
End Sub
And if you really want to condense it you can apply some boolean math to the setting of the interior.ColorIndex, but this only works because red and green are 1 colorindex value away from each other. Also the next person that adopts your code will hate you and won't think your nearly as clever as you think you are.
Sub greenOrRed()
Dim rngCell As Range
For Each rngCell In Sheet1.Range("H:H").Cells
If rngCell.Value = "" And rngCell.Row > 1 Then Exit For
If rngCell.Row Mod 2 = 0 Then rngCell.Resize(2).Interior.ColorIndex = 3 + Abs(rngCell.Value = rngCell.Offset(1).Value)
Next rngCell
End Sub
some other ways
another loop approach:
Sub CompareCells()
Dim i As Long
With Range("H2", Cells(Rows.Count,"H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
For i = 1 To .Count Step 2 ' loop through referenced range skipping every other row
With .Cells(i, 1) ' reference current cell
.Interior.Color = IIf(.Value2 = .Offset(1).Value2, vbGreen, vbRed) 'set current cell color with respect to below cell content
End With
Next
End With
End Sub
a no-loop approach:
Sub CompareCells()
With Range("H2", Cells(Rows.Count, "H").End(xlUp)) ' reference column H cells from row 2 down to last not empty one
With .Offset(, 1) ' reference referenced range 1 column to the right offset range. this is a "helpre" column
.FormulaR1C1 = "=IF(even(row())=row(),1,"""")" ' write 1's every two rows in referenced range
With .SpecialCells(xlCellTypeFormulas, xlNumbers) ' reference referenced range "numbered" rows
.Offset(, -1).Interior.Color = vbRed ' mark referenced range 1 column left offset in red
.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,"""")" ' signal referenced range cells with 1 if corresponding 1 column to the left offset cell content equals its below cell content
.SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1).Interior.Color = vbGreen ' turn reference referenced range "numbered" cells color to green
End With
.ClearContents ' clear referenced "helper" column
End With
End With
End Sub
I'm writing a VBA program to search through a large spreadsheet and copy rows that have the same account five or more times associated with the data to a different sheet. The program does exactly what it's supposed to do when I step through each individual line (F8), but when I run the program (F5), it doesn't end up copying any information to the second sheet. I've tried adding a two second delay between switching sheets and pasting the data, just in case this was the problem, but so far it hasn't helped.
Any suggestions?
Edit: I thought that the screen updating might be causing the problem, so I disabled it. The program still didn't paste the data in the other worksheet.
Second Edit: I noticed that when I put a stop in at the beginning of the while loop and step the program through in chunks, it also does not copy and paste the data like it should be. It still works when stepping through individual lines of code, though. I also removed the 2 second pauses as those didn't make a difference.
Here's the code:
Public Sub Main()
Worksheets(2).Activate
Range("A1").Select
Worksheets(1).Activate
Range("C2").Select
AcctName = ActiveCell.Value
LoopControl = 0
AcctNameCt = 1
CurrentAcctRow = ActiveCell.Row
Do While LoopControl <> 1
SecondLoopControl = 0
If AcctName = ActiveCell.Offset(AcctNameCt, 0).Value Then
AcctNameCt = AcctNameCt + 1
If AcctNameCt > 4 Then
GreaterThanFour
End If
ElseIf ActiveCell.Offset(AcctNameCt, 0).Value = "" Then
Exit Do
Else
ActiveCell.Offset(AcctNameCt, 0).Activate
AcctName = ActiveCell.Value
AcctNameCt = 1
CurrentAcctRow = ActiveCell.Row
End If
Loop
End Sub
Public Sub CopyData()
Dim EndRow As Integer
Dim StopCopy As Integer
Dim RestartRow As Integer
EndRow = CurrentAcctRow + AcctNameCt
StopCopy = EndRow - 1
RestartRow = EndRow + 1
ActiveSheet.Range("C" & CurrentAcctRow & ":" & "C" & StopCopy).EntireRow.Copy
Worksheets(2).Activate
LookForEmptyRow
ActiveCell.EntireRow.PasteSpecial
CurrentAcctRow = CurentAcctRow + 1
Worksheets(1).Activate
Range("C" & EndRow).Select
AcctNameCt = 0
End Sub
Public Sub GreaterThanFour()
Do While SecondLoopControl <> 1
If AcctName = ActiveCell.Offset(AcctNameCt, 0).Value Then
AcctNameCt = AcctNameCt + 1
Else
CopyData
SecondLoopControl = 1
End If
Loop
End Sub
Public Sub LookForEmptyRow()
Range("A1").Select
Dim LookAnotherLoopControl As Integer
LookAnotherLoopControl = 0
Do While LookAnotherLoopControl <> 1
If ActiveCell.Value = "" Then Exit Sub Else ActiveCell.Offset(1, 0).Activate
Loop
End Sub
I set the worksheet names to variables and called those, rather than calling the worksheets directly. For some reason, this works better.
Set wbA = Workbooks(Workbook Name)
Set wsA = Worksheets(Worksheet Name 1)
Set wsB = Worksheets(Worksheet Name 2)
Where the "Workbook Name" and "Worksheet Name 1" reflect the actual names, instead. Those are working better than:
Worksheets(2).Activate
LookForEmptyRow
ActiveCell.EntireRow.PasteSpecial
CurrentAcctRow = CurentAcctRow + 1
Worksheets(1).Activate
Range("C" & EndRow).Select
I also used a better method to look for an empty row, rather than writing my own subroutine. The original code had this sub that I wrote:
Public Sub LookForEmptyRow()
Range("A1").Select
Dim LookAnotherLoopControl As Integer
LookAnotherLoopControl = 0
Do While LookAnotherLoopControl <> 1
If ActiveCell.Value = "" Then Exit Sub Else ActiveCell.Offset(1, 0).Activate
Loop
Which, while effective, was highly inefficient. I replaced it with the much more efficient line of code:
lRow = Range("A1000").End(xlUp).Row
Cells(lRow + 1, 1).Activate
Currently working on an excel sheet to rank projects, we would like it to automatically increase the numbers if we insert a new line and input an existing number rank. If we put in a line and type in 9 for its rank we want the pre existing 9 to move to 10 and the old 10 to move to 11 etc. I have kind of worked it out, however my code automatically numbers the first row as 1 and so forth. This is what I have so far.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer
I = 1
Application.EnableEvents = False
For I = 1 To 20
Range("A" & I).Value = I
Next
Range("A21").Value = ""
Application.EnableEvents = True
End Sub
You could loop through every cell in column A and, if its value is greater than (or equal to) the one just changed, increment it by one:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim v As Long
Dim r As Range
Set r = Application.Intersect(Range("A:A"), Target)
If r Is Nothing Then
Exit Sub
End If
If r.Count > 1 Then
Exit Sub
End If
If IsEmpty(r.Value) Then
Exit Sub
End If
I = 1
v = r.Value
If Application.CountIf(Range("A:A"), v) > 1 Then ' Only change things if this
' value exists elsewhere
Application.EnableEvents = False
For I = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(I, "A").Address <> r.Address Then
If IsNumeric(Cells(I, "A").Value) Then ' skip cells that aren't numeric
If Cells(I, "A").Value >= v Then
Cells(I, "A").Value = Cells(I, "A").Value + 1
End If
End If
End If
Next
Application.EnableEvents = True
End If
End Sub
I need to be able to loop through my rows (specifically, column B), and use the number in a certain cell in order to do specific functions using other cells in that row. For example, Rule #1 indicates that I need to find last modified date of the path in the cell next to the Rule #, but the task is different for each Rule.
I'm new to VBA and I've just been struggling with setting up a loop and passing variables to different subs, and would hugely appreciate any help. To be clear, I'm looking for syntax help with the loop and passing variables
Thank you!
Reference Images: The spreadsheet
The attempt at sketching out the code
Private Sub CommandButton1_Click()
Dim x As Integer
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
For x = 1 To NumRows
If Range(RowCount, 1).Value = 1 Then
RuleOne (RowCount)
End If
Next
'Dim RowCount As Integer
'RowCount = 1
'Worksheets("Sheet2").Cells(1, 2) = Worksheets("Sheet1").UsedRange.Row.Count
'While RowCount < Worksheets("Sheet1").Rows
'If Worksheets("Sheet1").Cells(RowCount, 1).Value = 1 Then
'RuleOne (RowCount)
'End If
'Wend
End Sub
Sub RuleOne(i As Integer)
'use filedatetime and path from i cell
'Worksheets("Sheet2").Cells(1, 1) = FileDateTime(C, i)
Worksheets("Sheet2").Cells(1, 1) = "hello"
End Sub
Sub RuleTwo(i As Integer)
Worksheets("Sheet2").Cells(1, 1) = "hello"
End Sub
Try to change the Range(RowCount, 1).Value = 1 to Cells(x, 2).Value = 1.
The variable RowCount has not been initialised/set.
I assume this is what this variable is meant to be the number in column B
RowCount = Cells(x, "B").Value
I also noticed that the variable NumRows seemed to be one less than it should be (so if the last row was 1 it would skip it). So I used this instead:
NumRows = Cells(Rows.Count, "B").End(xlUp).Row
So try this code:
Sub CommandButton1_Click()
Dim x As Integer
NumRows = Cells(Rows.Count, "B").End(xlUp).Row
For x = 1 To NumRows
RowCount = Range("B" & x).Value
If RowCount = 1 Then
RuleOne (x)
End If
Next
'Dim RowCount As Integer
'RowCount = 1
'Worksheets("Sheet2").Cells(1, 2) = Worksheets("Sheet1").UsedRange.Row.Count
'While RowCount < Worksheets("Sheet1").Rows
'If Worksheets("Sheet1").Cells(RowCount, 1).Value = 1 Then
'RuleOne (RowCount)
'End If
'Wend
End Sub
Sub RuleOne(i As Integer)
'use filedatetime and path from i cell
'Worksheets("Sheet2").Cells(1, 1) = FileDateTime(C, i)
Worksheets("Sheet2").Cells(1, i) = "hello"
End Sub
Sub RuleTwo(i As Integer)
Worksheets("Sheet2").Cells(1, 1) = "hello"
End Sub
I have an issue with my VBA code. I try to compare 2 columns, both A and B columns. If some data match, for example let's say that A2 contains text in B3, then I need to compare the cell C2 with the column D. I don't understand why but I get the error "End If without block If". Thanks a lot for you help guys.
Here is my code :
Sub Compare()
For i = 1 To 100
For j = 1 To 50
If InStr(1, ActiveSheet.Cells(i, 1).Value, ActiveSheet.Cells(j, 2).Value, vbTextCompare) <> 0 _
Then For k = 1 To 20
If InStr(1, ActiveSheet.Cells(i, 3).Value, ActiveSheet.Cells(k, 4).Value, vbTextCompare) <> 0 Then MsgBox i
End If
Next k
End If
Next j
Next i
End Sub
I found the structure of your if statements a bit confusing and I'm not entirely sure you can do a for loop as a one-liner like that to get rid of all the end ifs. For what it's worth, I think this code is a bit easier to follow:
Sub Compare()
For i = 1 To 100
For j = 1 To 50
If InStr(1, ActiveSheet.Cells(i, 1).Value, ActiveSheet.Cells(j, 2).Value, vbTextCompare) <> 0 Then
For k = 1 To 20
If InStr(1, ActiveSheet.Cells(i, 3).Value, ActiveSheet.Cells(k, 4).Value, vbTextCompare) <> 0 Then MsgBox i
Next k
End If
Next j
Next i
End Sub
This runs w/o a compile error, but can't comment if it does what you want it to do.
sous2817 raised an interesting question in their answer about whether or not a 1-line statement works if the body of the if statement is itself a for-loop. The answer appears to be "no" -- unless the for-loop itself is squeezed onto one line by using the colon statement separator:
Sub test1() 'compile error
Dim i As Long, s As Long
If i = 0 _
Then For i = 1 To 10
s = s + i
Next i
MsgBox s
End Sub
Sub test2() 'compiles okay
Dim i As Long, s As Long
If i = 0 _
Then For i = 1 To 10: s = s + i: Next i
MsgBox s
End Sub
If statements on one line don't need the End If statement.
End If without block If
Sub comparison()
For i = 2 To 1000
For j = 2 To 1000
If Worksheets(Worksheet).Range("A" & i).Value = Worksheets(Worksheet).Range("L" & j).Value Then
Worksheets(worksheet).Range("N" & j).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next j
Next i
End Sub