I have the following code that I need to repeat 1000 times:
Option Explicit
Sub Turn()
Range("f2").Select
If Range("e2").Value = "00/00/00" Then
ActiveCell.Value = 0
ElseIf Range("e2").Value Then
ActiveCell.Value = Range("e2")
End If
Range("f2").Select
If ActiveCell.Value > 0 Then
Range("G2") = Range("f2") - Range("b2")
End If
End Sub
I am new so I don't know if it is the most elegant solution to my problem, but it does the job. The problem is that I need the same code for 1000 rows and it seems a mighty task to change the cell number manually that many times.
Can You help me solve my problem?
I appreciate all help, thanks in advance.
you could achieve it using a 'for loop'. This should be on the right lines:
Option Explicit
Sub Turn()
Dim i As Long
For i = 2 to 1001
Range("f" & i).Select
If Range("e" & i).Value = "00/00/00" Then
ActiveCell.Value = 0
ElseIf Range("e" & i).Value Then
ActiveCell.Value = Range("e" & i)
End If
Range("f" & i).Select
If ActiveCell.Value > 0 Then
Range("G" & i) = Range("f" & i) - Range("b" & i)
End If
Next i
End Sub
Try it out and see where you get, let us know how it goes :)
This will be much quicker with an array:
Sub Recut()
Dim X, Y
Dim lngCnt As Long
X = [F2:G1001].Value2
Y = [B2:B1001].Value2
For lngCnt = 1 To UBound(X)
If X(lngCnt, 1) = "00/00/00" Then
X(lngCnt, 1) = 0
Else
If X(lngCnt, 1) > 0 Then X(lngCnt, 2) = X(lngCnt, 1) - Y(lngCnt, 1)
End If
Next
[F2:G1001].Value2 = X
End Sub
This is for your learning that you should avoid .Select in your code.
Pls have a look here
pls see the below simplified code.
Sub Turn()
Dim i As Long
For i = 2 To 1001
If Range("F" & i).Value = "00/00/00" Then
Range("F" & i).Value = 0
ElseIf Range("F" & i).Value > 0 Then
Ramge("G" & i).Value = Range("F" & i).Value - Range("B" & i).Value
End If
Next i
End Sub
Don't use "A1" style cell addresses but Cell(Row, Col) instead ...
Related
This code works perfectly if I run it in break mode by stepping through each line. However, if I run it normally, it seems like it just skips to the end. It gives me a message box of a one second run time and none of the lines of code have been executed. Any help would be greatly appreciated!
Sub addVals()
Dim i As Integer, j As Integer, sheetName As String, timer As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
timer = Now()
For i = 1 To 7
sheetName = Range("sheetnames2").Offset(i, 0).Value
For j = 1 To 3000
If Sheets(sheetName).Range("P" & j).Value <> 0 Then
For Each Cell In Range("R" & j, "R" & j + 30)
If Cell = 1 Then Range("S" & j).Value = Cell.Offset(0, -17).Value: Exit For
Next Cell
Else
End If
Next j
Next i
Application.Calculation = xlCalculationAutomatic
MsgBox (Format(Now() - timer, "HH:MM:SS"))
End Sub
Couple of corrections:
Sub addVals()
Dim i As Integer, j As Integer, sheetName As String, timer As Double
Dim sht As Worksheet, Cell As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
timer = Now()
For i = 1 To 7
sheetName = Range("sheetnames2").Offset(i, 0).Value
With Sheets(sheetName) '<< scope the loop to the correct sheet
For j = 1 To 3000
If .Range("P" & j).Value <> 0 Then
For Each Cell In .Range("R" & j).Resize(30, 1).Cells
If Cell.Value = 1 Then
.Range("S" & j).Value = Cell.Offset(0, -17).Value
Exit For '<< unless you really meant what you wrote?
End If
Next Cell
End If
Next j
End With
Next i
Application.Calculation = xlCalculationAutomatic
MsgBox (Format(Now() - timer, "HH:MM:SS"))
End Sub
Note this one-liner:
If Cell = 1 Then Range("S" & j).Value = Cell.Offset(0, -17).Value: Exit For
is functionally the same as:
If Cell = 1 Then
Range("S" & j).Value = Cell.Offset(0, -17).Value
End If
Exit For
and is not the same as:
If Cell = 1 Then
Range("S" & j).Value = Cell.Offset(0, -17).Value
Exit For
End If
...so it might not be behaving as you expect
Can anybody please help me figure out my problem?
I have this code that I would like to move to the next column if the condition is not met.I'm stuck and don't know where to proceed.
Dim lrow3, lrow1 as long
dim dDate as Date
dim yrNum, j as Integer
dDate = Format(Now(),"mm/dd/yyyy")
lrow3 = ActiveSheet.Cells(Rows.count, 2).End(xlUp).Row
lrow1 = Sheets("Sample").Cells(Rows.count, 2).End(xlUp).Row
for j = 2 to lrow1
For yrNum = 1 To 100
If DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) >= DateValue(dDate) And _
DateValue(Format(Range("R" & j).Value, "mm/dd/yyyy")) <= DateValue(dDate) Then
ActiveSheet.Range("D" & lrow3 + 1).Value = Range("T" & j).Value
ActiveSheet.Range("E" & lrow3 + 1).Value = Range("U" & j).Value
Exit For
Else
Range("Q" & j) = ActiveCell
Range("Q" & j) = ActiveCell.Offset(0, 9)
'after executing this is I have to set this offsetted cell to be the active one
'on which i will be referring in the next loop
End If
Next yrNum
next j
In the snippet, if the value in Q & j does not met the requirements, then i have to check the 9th letter after Q which is Z and so on.
By the way what I'm comparing on this are date values in the cell.
A few observations
dDate = Format(Now(),"mm/dd/yyyy") is the same as dDate = Date
DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) is the same asDateValue(Range("Q" & j).Value)`
You are starting in column Q and if the conditions are not meet you move over 9 columns and check again. You do this 100 times. The final column is column 917(column letter code AIG)
Sub RefactoredCode()
Dim lrow3, lrow1 As Long
Dim DateRange As Range
Dim wsSample As Worksheet
Dim yrNum, j As Integer, iOffset As Integer
Set wsSample = Worksheets("Sample")
lrow3 = Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = wsSample.Cells(Rows.Count, 2).End(xlUp).Row
For j = 2 To lrow1
For yrNum = 1 To 100
iOffset = (yrNum * 9) - 9
Set DateRange = wsSample.Cells(j, "Q").Offset(0, iOffset)
If DateValue(DateRange.Value) >= Date And _
DateValue(DateRange.Offset(0, 1).Value) <= Date Then
lrow3 = lrow3 + 1
Range("D" & lrow3).Value = wsSample.Cells(j, "T").Offset(0, iOffset).Value
Range("E" & lrow3).Value = wsSample.Cells(j, "U").Offset(0, iOffset).Value
Exit For
End If
Next yrNum
Next j
End Sub
This macro takes 2+ minutes to run. What are the best methods to optimize the macro?
Sub Time_Color(z, k)
Application.DisplayAlerts = False
For Each cell In Sheet1.Range("C" & z & ":" & "LZ" & z)
If cell.Value <> "x" Then
If cell.Value < Sheet3.Range("D" & k) Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = Sheet4.Range("D" & k).Value & "_" & Sheet4.Cells(k, 5).Value
End If
For j = 5 To 1000 Step 2
If cell.Value > Sheet3.Cells(k, j).Value And cell.Value < Sheet3.Cells(k, j + 1).Value Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = Sheet4.Cells(k, j + 1).Value & "_" & Sheet4.Cells(k, j + 2).Value
End If
Next j
For j = 4 To 1000 Step 2
If cell.Value >= Sheet3.Cells(k, j).Value And cell.Value <= Sheet3.Cells(k, j + 1).Value Then
cell.Interior.ColorIndex = 43
cell.Offset(1, 0).Value = Sheet4.Cells(k, j).Value & "_" & Sheet4.Cells(k, j + 1).Value
End If
Next j
End If
Next cell
Application.DisplayAlerts = True
End Sub
I am running this macro for 24 different combinations of z,k.
Try caching as much data as possible, for instance Sheet3.Range("D" & k) is constant throughout this function.
Every instance of the inner most loop will query that cell. If you put it at the beginning of this function, it will be looked up once and then used for the remainder of the function.
Edit:
In the comments on this question is - I think - a better answer by Tim Williams, which is specific to VBA:
Turn off ScreenUpdating and Calculation while running. Calculation
should be reset before your Sub ends (ScreenUpdating will reset
itself)
I'm not entirely sure what you are trying to accomplish, but it seems that your loop iterates over a large range to find the last-most instance of a cell that satisfies one of the two given criteria (your two loops).
If that is the goal, why not start from the back? Depending on how your sheet looks, this is potentially a lot faster!
I also made some other changes. Let me know how it works.
Take care to also include the function at the bottom (heisted from this answer), or substitute it for your function of choice.
Sub Time_Color(z, k)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim loopVal, loopVal2, loopVal3 As Variant
Dim setOdd, setEven, OddEven As Boolean
Dim compVal, compVal2, compVal3 As Variant
compVal = Sheet3.Range("D" & k).Value
compVal2 = Sheet4.Range("D" & k).Value
compVal3 = Sheet4.Cells(k, 5).Value
For Each cell In Sheet1.Range("C" & z & ":" & "LZ" & z)
If cell.Value <> "x" Then
If cell.Value < compVal Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = compVal2 & "_" & compVal3
End If
For j = 1000 To 4 Step -1
loopVal = Sheet3.Cells(k, j).Value
loopVal2 = Sheet3.Cells(k, j + 1).Value
loopVal3 = Sheet4.Cells(k, j + 1).Value
OddEven = OddOrEven(j)
If OddEven = True Then
If cell.Value > loopVal And cell.Value < loopVal2 Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = loopVal3 & "_" & Sheet4.Cells(k, j + 2).Value
setOdd = True
End If
Else
If cell.Value >= loopVal And cell.Value <= loopVal2 Then
cell.Interior.ColorIndex = 43
cell.Offset(1, 0).Value = Sheet4.Cells(k, j).Value & "_" & loopVal3
setEven = True
End If
End If
If setEven = True And setOdd = True Then Exit For
Next j
End If
Next cell
Application.DisplayAlerts = True
End Sub
Function OddOrEven(a As Integer) As Boolean ' Returns TRUE if a is an odd number
If a - (2 * (Fix(a / 2))) <> 0 Then OddOrEven = True
End Function
I have big data file on excel, the file has 6930 rows and 8 columns,
the 8 column has percents (0%, 4%, 16%, 18%, 19% and etc..)
I tried to do a macro that paint all the rows that the percent in them are bigger then 18%, and it doesn't work.
The file start from row 3, so rows 1 and 2 are empty
The macro:
Sub Test_4
Dim i As Long
Dim countErr As Long
countErr = 0
i = 2
Do While Cells(i, 1) = ""
If Cells(i, 8).Value > 0.18 And IsNumeric(Cells(i, 8)) Then
Range(Cells(i, 1), Cells(i, 8)).Interior.ColorIndex = 3
countErr = countErr + 1
End If
i = i + 1
Loop
If countErr > 0 Then
Sheets("test").Select
Range("E8").Select
Selection.Interior.ColorIndex = 3
Range("D8").Select
Selection.FormulaR1C1 = countErr
Else
Sheets("test").Select
Range("E8").Select
Selection.Interior.ColorIndex = 4
Sheets("test").Range("d8") = "0"
End If
End Sub
A Do While loop might be a bad idea if Column H ever has a blank value part way down, instead you could do this (This will add conditional formatting to each line):
Given this input:
Sub testit()
Dim LastRow As Long, CurRow As Long, countErr As Long
LastRow = Range("H" & Rows.Count).End(xlUp).Row
Cells.FormatConditions.Delete
With Range("A3:H" & LastRow)
.FormatConditions.Add Type:=xlExpression, Formula1:="=$H3>0.18"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.ColorIndex = 3
.FormatConditions(1).StopIfTrue = False
End With
countErr = 0
Dim cel As Range
For Each cel In Sheets("NAME OF SHEET").Range("H3:H" & LastRow)
If cel.Value > 0.18 Then
countErr = countErr + 1
End If
Next cel
MsgBox "There are " & countErr & " rows greater than 18%"
End Sub
Running the code gives:
Error Testing:
Sub ErrorTesting()
Dim cel As Range, countErr As Long
countErr = 0
LastRow = Range("H" & Rows.Count).End(xlUp).Row
For Each cel In Range("H3:H" & LastRow)
On Error GoTo ErrHandle
If Not IsNumeric(cel.Value) Then
MsgBox cel.Address & " is the address of the non-numeric Cell"
End If
If cel.Value > 0.18 And IsNumeric(cel.Value) Then
countErr = countErr + 1
End If
Next cel
ErrHandle:
If Not cel Is Nothing Then
MsgBox cel.Address & " is the address and " & cel.Value & " is the value of the Error Cell"
End If
MsgBox countErr
End Sub
Try this (updated for error count):
Sub test()
Count = 0
i = 2
While Not IsEmpty(Cells(i, 8))
If Cells(i, 8).Value > 0.18 Then
Range(Cells(i, 1), Cells(i, 8)).Interior.ColorIndex = 3
Count = Count + 1
End If
i = i + 1
Wend
//rows count bigger than 18% in worksheet "test"
Worksheets("test").Cells(1, 1).Value = "Rows count bigger than 18%"
Worksheets("test").Cells(1, 2).Value = Count
End Sub
I'm using this script to insert fill with rows where non-sequential is produced in a column of an excel file.
Sub InsertValueBetween()
Dim lastrow As Long
Dim gap As Long
Dim i As Long, ii As Long
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastrow To 3 Step -1
gap = .Cells(i, "A").Value - .Cells(i - 1, "A").Value
If gap > 1 Then
.Rows(i).Resize(gap - 1).Insert
End If
Next i
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(3, "A").Value = .Cells(2, "A").Value + 1
.Cells(2, "A").Resize(2).AutoFill .Cells(2, "A").Resize(lastrow - 1)
End With
End Sub
In addition to adding these new rows I want them to also have a specific value in column B. I'm trying to implement this but with no result.
Anybody could help me?
One way you could tackle this challenge is with a Range variable. Here is some heavily-commented code that walks through the process:
Sub InsertValueBetweenRev2()
Dim Target As Range '<~ declare the range variable
'... declare your other variables
'... do other stuff
For i = lastrow To 3 Step -1
gap = .Cells(i, "A").Value - .Cells(i - 1, "A").Value
If gap > 1 Then
.Rows(i).Resize(gap - 1).Insert
'the next line sets the range variable to the recently
'added cells in column B
Set Target = .Range(.Cells(i, 2), .Cells(i + gap - 2, 2))
Target.Value = "Cool" '<~ this line writes text "Cool" into those cells
End If
Next i
'... the rest of your code
End Sub
So, to sum it up, we know that gap - 1 rows are going to be added, and we know that the new rows are added starting at row i. Using that knowledge, we assign the just-added cells in column B to a Range then set the .value of that Range to whatever is needed.
a Better way of doing it with less variables and faster:
Sub InsRowWithText()
Dim LR As Long, i As Long
LR = Range("D" & Rows.Count).End(xlUp).row
For i = LR To 3 Step -1
If Range("D" & i).Value <> Range("D" & i - 1).Value Then
Rows(i).Resize(1).Insert
Range("D" & i).Value = "Test"
End If
Next i
End Sub
This is how i utilized it:
Sub InsRowWithText()
Dim strMsg As String, strTitle As String
Dim LR As Long, i As Long
Text = "ADD"
strMsg = "Warning: This is a Advanced Function, Continue? "
strTitle = "Warning: Activated Advanced Function "
If MsgBox(strMsg, vbQuestion + vbYesNo, strTitle) = vbNo Then
Exit Sub
Else
Sheets("SAP Output DATA").Select
If Range("D3").Value = Text Then
MsgBox "Detected That This Step Was Already Completed, Exiting."
Exit Sub
End If
application.ScreenUpdating = False
LR = Range("D" & Rows.Count).End(xlUp).row
For i = LR To 3 Step -1
If Range("D" & i).Value <> Range("D" & i - 1).Value Then
Rows(i).Resize(1).Insert
Range("D" & i).EntireRow.Interior.ColorIndex = xlColorIndexNone
Range(("A" & i), ("D" & i)).Value = Text
End If
Next i
End If
Range("D2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1).Select
Range(("A" & ActiveCell.row), ("D" & ActiveCell.row)).Value = Text 'last row doesnt get text for some reason.
ActiveCell.EntireRow.Interior.ColorIndex = xlColorIndexNone
ActiveCell.Offset(1).Select
Range(("D" & ActiveCell.row), ("E" & ActiveCell.row)).Interior.ColorIndex = 17 'purple
application.ScreenUpdating = True
Range("D3").Select
End Sub