Using a negative loop number in VBA - excel

I have a for loop, using i as the counter, in Excel VBA. I have one statement that stubbornly gives me errors:
ActiveCell.FormulaR1C1 = "=VLookup(RC[-3],R3C7:R22C15,3)" & " & " & "R[-i]C" & " _
& " & "Vlookup(RC[-3],R3C7:R22C15,4)"
Using the -i is evidently causing the errors. I tried adding
negi=-i and then changing the R[-i]C to R[negi]C, but that didn't fix it. I added a Dim negi as Integer statement in earlier code.
Edit: Here's more of the code. I'm using two loops. rownumber is the counter for the outer loop, and i is the counter for the inner loop. i ranges from 1 to 20, and rownumber ranges until a row is reached with a blank in column 3.
Range("A25").Select
Dim Rownumber As Integer
Dim i As Integer
Dim negi As Integer
Rownumber = 1
' This starts the outer loop
Do While ActiveCell.Offset(0, 3) <> ""
' Adds twenty rows
ActiveCell.Offset(1, 0).Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(19, 5)).Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset(-1, 0).Select
For i = 1 To 20
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = i
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Rownumber
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=Vlookup(RC[-2],R3C7:R22C15,2)"
ActiveCell.Offset(0, 1).Select
negi = -i
ActiveCell.FormulaR1C1 = "=VLookup(RC[-3],R3C7:R22C15,3)" & " & " & _
"R[negi]C" & " & "& "Vlookup(RC[-3],R3C7:R22C15,4)"
....
rownumber = rownumber + 1
next i
How can I accomplish this while avoiding errors?

There are a couple of bad string concatenations in the formula build.
i will have to be outside of the quoted string(s) and concatenated in and & " & " & probably isn;t doing what you want it to.
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],R3C7:R22C15,3)&" & _
""" & ""&R[-" & i & "]C&"" & ""&" & _
"VLOOKUP(RC[-3],R3C7:R22C15,4)"
Remember that you have to double up quotes within a quoted string.

You can do a loop from a greater value to a lower value. This will loop from the last cell used to the first.
lRow = ws.UsedRange.Rows.count
Do While lRow > 0
lCol = ws.UsedRange.Columns.count
Do While lCol > 0
If InStr(ws.Cells(lRow, lCol), job) Then
End If
lCol = lCol - 1
Loop
lRow = lRow - 1
ws.Range("A" & lRow).Activate
Loop

Related

Worksheet functions in VBA - How do I speed up this macro?

First of all, I´m a pretty new and ineffective VBA user, which you´ll definitely notice.
I have created a macro with loops that runs extremely slowly (about 10 minutes depending on the dataset, which differs in size every time) and I´m guessing that there´s a much better way of doing it than mine.
Basically, what I´m trying to do is automate a job that includes a lot of built-in functions in Excel. I got four columns and X amount of rows that need to be populated with formulas.
My idea was to calculate the formula for all four columns in row 1, then moving on to row 2 all the way to row X, using a simple "do loop". It looks something like this:
Range("j2").Select
rownumber = ActiveCell.Row
Do
'check if the cell on the left is empty to determine whether it´s the last row or not.
Range("J" & rownumber).Select
Range("J" & rownumber).Offset(0, -1).Select
If IsEmpty(ActiveCell) = True Then
Exit Do
Else
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=INDEX(Sheet1!C[-4],MATCH(Sheet2!R[0]C[-6],Sheet1!C[-9],0))"
'next column
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=INDEX(sheet1!C[-6],MATCH(sheet2!RC[-7],sheet1!C[-10],0))"
'next column
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=INDEX(sheet3!C[-10],MATCH(sheet2!RC[-2],sheet1!C[-11],0))*sheet2!RC[-1]*sheet2!RC[-10]"
'next column
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = _ "=IF(sheet2!RC[-12]=""BUY"",SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])+sheet2!RC[-11],SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])-sheet2!RC[-11])"
ActiveCell.Offset(0, 1).Select
rownumber = rownumber + 1
End If
Loop
This all works, but there must be a better solution that runs smoother. I understand that Excel needs to do lots of calculations with the nested if statements, but it would probably take me less than 10 minutes to do this manually, so I´m guessing it´s my code that slows things up.
I would modify your code this way:
Dim xlcOld As Calculation: xlcOld = Application.Calculation
Application.Calculation = xlCalculationManual
Dim rownumber As Long: rownumber = 2
Do While Not IsEmpty(Range("I" & rownumber).Value)
Range("J" & rownumber).FormulaR1C1 = "=INDEX(Sheet1!C[-4],MATCH(Sheet2!R[0]C[-6],Sheet1!C[-9],0))"
Range("K" & rownumber).FormulaR1C1 = "=INDEX(sheet1!C[-6],MATCH(sheet2!RC[-7],sheet1!C[-10],0))"
Range("L" & rownumber).FormulaR1C1 = "=INDEX(sheet3!C[-10],MATCH(sheet2!RC[-2],sheet1!C[-11],0))*sheet2!RC[-1]*sheet2!RC[-10]"
Range("M" & rownumber).FormulaR1C1 = "=IF(sheet2!RC[-12]=""BUY"",SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])+sheet2!RC[-11],SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])-sheet2!RC[-11])"
rownumber = rownumber + 1
Loop
Application.Calculation = xlcOld
Note that:
Automatic recalculation is turned off, so only one recalculation is needed instead of 4 × rownumber calculations
Select operations are replaced with direct cell references
As BigBen indicated, it can be even more efficient by writing formulas in one go:
Dim xlcOld As Calculation: xlcOld = Application.Calculation
Application.Calculation = xlCalculationManual
Dim firstrow As Long: firstrow = 2
Dim lastrow As Long: lastrow = firstrow
Do While Not IsEmpty(Range("I" & lastrow).Value)
lastrow = lastrow + 1
Loop
lastrow = lastrow - 1
Range("J" & firstrow & ":J" & lastrow).FormulaR1C1 = "=INDEX(Sheet1!C[-4],MATCH(Sheet2!R[0]C[-6],Sheet1!C[-9],0))"
Range("K" & firstrow & ":J" & lastrow).FormulaR1C1 = "=INDEX(sheet1!C[-6],MATCH(sheet2!RC[-7],sheet1!C[-10],0))"
Range("L" & firstrow & ":J" & lastrow).FormulaR1C1 = "=INDEX(sheet3!C[-10],MATCH(sheet2!RC[-2],sheet1!C[-11],0))*sheet2!RC[-1]*sheet2!RC[-10]"
Range("M" & firstrow & ":J" & lastrow).FormulaR1C1 = "=IF(sheet2!RC[-12]=""BUY"",SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])+sheet2!RC[-11],SUMIFS(sheet4!C[-7],sheet4!C[-12],sheet2!RC[-6],sheet4!C[-11],sheet2!RC[-9])-sheet2!RC[-11])"
Application.Calculation = xlcOld
Whether this adds significant benefit, depends on the actual data. I think most of the work comes from recalculations and not from modifying the formulas but if rownumber is a really big number a further enhancement may be possible.
Also, you could find the last row with Range.End(xlUp) but that depends on the actual layout of your sheet, so I did not remove the loop counting the number of rows.

How to select row before and after row with specific text in Excel?

My raw data looks something like this;
std1
std1
deviant
std2
std1
std2
std2
deviant
The "deviants" are presented randomly and thus do not occur every nth row...
I wish to select 1 row before and 1 row after each "deviant" row so I can copy it in another spread sheet.
See code below.
We loop through each row in the column (I have assumed your data is in column A) and when the given value is found, we add the following and prior rows to our selection array. When the loop is complete, we select the rows in the array
Public Sub DeviantSelect()
Dim myRange As Range
Set myRange = Nothing
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow
If Cells(i, 1) = "deviant" Then
If myRange Is Nothing Then
Set myRange = Union(Range(i - 1 & ":" & i - 1), Range(i + 1 & ":" & i + 1))
Else
Set myRange = Union(myRange, Range(i - 1 & ":" & i - 1), Range(i + 1 & ":" & i + 1))
End If
myRange.Select
End If
Next
End Sub
The below code copies the cells before and after deviant to another sheet.
Sub check()
Sheet1.Activate
Range("A1").Select
LastRow = Sheets("Sheet1").UsedRange.Rows(Sheets("Sheet1").UsedRange.Rows.Count).Row
For i = 1 To LastRow
Sheet1.Activate
If Range("A" & i).Value = "deviant" Then
Range("A" & i - 1).Select
Selection.Copy
Sheet2.Activate
LastRow2 = Sheets("Sheet2").UsedRange.Rows(Sheets("Sheet2").UsedRange.Rows.Count).Row
If LastRow2 = 1 Then
Range("A" & LastRow2).Activate
Else
Range("A" & LastRow2 + 1).Activate
End If
ActiveSheet.Paste
Sheet1.Activate
Range("A" & i + 1).Select
Selection.Copy
Sheet2.Activate
LastRow2 = Sheets("Sheet2").UsedRange.Rows(Sheets("Sheet2").UsedRange.Rows.Count).Row
Range("A" & LastRow2 + 1).Activate
ActiveSheet.Paste
End If
Next
End Sub

countif in macros gives 0 results

​I was trying to do a countif in a column B named First Name that has different names in it but the results is returning 0.
Here is my code:
Public Sub counting()
Dim lastcell As String
Range("B2").Select
Selection.End(xlDown).Select
lastcell = ActiveCell.Address
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "=countif(B2:" + lastcell + ", John)"
End Sub
If I check the formula written in the active cell it is:
=COUNTIF(B2:$B$16, John)
Please help.
I tried changing the line from
ActiveCell.Value = "=countif(B2:" + lastcell + ", John)"
to
ActiveCell.Value = "=countif(B2:" + lastcell + ", "John")" still not working.
Public Sub counting()
With Range("B2").End(xlDown)
.Offset(1, 0).Formula = "=COUNTIF(B2:" & .Address(False, False) & ", ""John"")"
End with
End Sub
Try,
ActiveCell.formula = "=countif(B2:" & lastcell & chr(44) & chr(34) &"John" &chr(34) & ")"

Excel list VBA concatenate

Image below shows an Excel list I have. Columns A-C is the contents I have. Columns D and E is the result I'm looking for. I've manually entered it to show the result.
Currently my code looks like this:
Option Explicit
Sub New_SKU()
Dim wb As Workbook
Dim ws As Worksheet
'figure out how far down data goes
Dim endrow As Long
Dim currentrow As Long
Dim basename
Set wb = ThisWorkbook
Set ws = wb.Sheets("Blad1")
With ws
endrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'always start in the correct column
.Cells(.Cells(1, "B").End(xlDown).Row, "B").Activate
'loop through all data
Do While ActiveCell.Row < endrow
'loop through empty cells and set formula if cell isn't empty
Do While ActiveCell.Row <= endrow
'if next cell isn't empty, isn't past the end of the list, go to outer loop
If ActiveCell.Formula <> "" And ActiveCell.Offset(1, 0).Formula = "" And ActiveCell.Row <= endrow Then
basename = Selection.Address
ActiveCell.Offset(0, 2).Formula = "=CONCATENATE(" & basename & ",""-""," & "C" & Selection.Row & ")"
' ActiveCell.Offset(0, 3).Formula = "=" & basename & ""
ActiveCell.Offset(1, 0).Activate
' If ActiveCell.Formula = "" And ActiveCell.Offset(0, 1).Formula <> "" And ActiveCell.Row <= endrow Then
' ActiveCell.Offset(0, 2).Formula = "=CONCATENATE(" & basename & ",""-""," & "C" & Selection.Row & ")"
' ActiveCell.Offset(0, 3).Formula = "=" & basename & ""
' ActiveCell.Offset(1, 0).Activate
' If ActiveCell.Formula = "" And ActiveCell.Offset(0, 1).Formula <> "" And ActiveCell.Row <= endrow Then
' ActiveCell.Offset(0, 2).Formula = "=CONCATENATE(" & basename & ",""-""," & "C" & Selection.Row & ")"
' ActiveCell.Offset(0, 3).Formula = "=" & basename & ""
' ActiveCell.Offset(1, 0).Activate
' If ActiveCell.Formula = "" And ActiveCell.Offset(0, 1).Formula <> "" And ActiveCell.Row <= endrow Then
' ActiveCell.Offset(0, 2).Formula = "=CONCATENATE(" & basename & ",""-""," & "C" & Selection.Row & ")"
' ActiveCell.Offset(0, 3).Formula = "=" & basename & ""
' ActiveCell.Offset(1, 0).Activate
' If ActiveCell.Formula = "" And ActiveCell.Offset(0, 1).Formula <> "" And ActiveCell.Row <= endrow Then
' ActiveCell.Offset(0, 2).Formula = "=CONCATENATE(" & basename & ",""-""," & "C" & Selection.Row & ")"
' ActiveCell.Offset(0, 3).Formula = "=" & basename & ""
' ActiveCell.Offset(1, 0).Activate
' If ActiveCell.Formula = "" And ActiveCell.Offset(0, 1).Formula <> "" And ActiveCell.Row <= endrow Then
' ActiveCell.Offset(0, 2).Formula = "=CONCATENATE(" & basename & ",""-""," & "C" & Selection.Row & ")"
' ActiveCell.Offset(0, 3).Formula = "=" & basename & ""
' ActiveCell.Offset(1, 0).Activate
Else
Exit Do
End If
' End If
' End If
' End If
' End If
' End If
Loop
Loop
End With
End Sub
I am reusing code from a similar problem I received help with earlier.
My first problem:
If uncomment the If-statements, when I start the script Excel goes blank (white) and stalls immediatly.
Running the script in its current state (If-satements commented out), I can see that I get the correct result in cell D2 and then cell B3 is selected (keep in mind that there are no results in column D or E), and then the screen goes blank and Excel stalls. I do not get any result in column E.
Since there are variation in sizes (column C), it can vary from 2-3 to 5-6.
I cannot figure out why I won't receive a result in E-column and why it stalls and goes white.
Any ideas?
As per comment above, here is a different approach
Sub x()
Dim r As Long
Columns(2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=r[-1]c"
For r = 2 To Range("A" & Rows.Count).End(xlUp).Row
Cells(r, 4).Value = Cells(r, 2).Value & "-" & Cells(r, 3).Value
Cells(r, 5).Value = Cells(r, 2).Value
Next r
Columns(2).SpecialCells(xlCellTypeFormulas).ClearContents
End Sub
If you're okay with a non-VBA answer, you can paste this formula in D2 and copy down:
=IF(B2="",LEFT(D1,FIND("-",D1)-1)&"-"&C2,B2&"-"&C2)

VBA on arrays runs too slow

The file I work on contains about 80,000 rows
I need to perform some basic checks and copy the results to the new sheet.
The whole thing takes about 8 minutes and I think its too long, is there any faster way?
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
lastCell = checkbook.UsedRange.Rows.Count
ReDim dataArray(2 To lastCell, 1 To 4)
For i = 2 To lastCell
dataArray(i, 1) = checkbook.Range(streetAddress & i).Value
dataArray(i, 2) = checkbook.Range(cityAddress & i).Value
dataArray(i, 3) = checkbook.Range(stateAddress & i).Value
dataArray(i, 4) = checkbook.Range(postCodeAddress & i).Value
Next I
For i = 2 To lastCell
If dataArray(i, 1) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK Street"
End If
If dataArray(i, 2) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK City"
End If
If dataArray(i, 3) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK State"
End If
If dataArray(i, 4) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK PostCode"
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I feel your pain, I had a sheet like that as well. Working cell by cell will be slow.
Try:
1) Can you try copy the whole Sheet not cell by cell so you have a backup before processing your blanks.
Some of my old code that you can use to modify, copy whole range in one go and put values in a brand new sheet:
Dim s1 As Worksheet
Dim s2 As Worksheet
Set s1 = ThisWorkbook.Sheets(strSourceSheet)
' What is range of source data
lastrow = s1.UsedRange.Rows.Count
lastcol = s1.UsedRange.Columns.Count
' copy across
s1.Range(s1.Cells(1, 1), s1.Cells(lastrow, lastcol)).Copy
' Create new empty worksheet for holding values
Set s2 = Worksheets.Add
s2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, SkipBlanks:=True
Application.CutCopyMode = False
' You can rename this s2 sheet
2) Then try SEARCH for your blank cells in each column and do a REPLACE. (Use Macro recorder to help get the syntax).
Some sample code below, you will need to clean this up by setting the range instead of using a select on whole column (which will add to blanks below your last row).
' go through each of your columns. Did street example here
Columns("A:A").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Replace What:="", Replacement:="BLANK street", LookAt:=xlWhole _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Hope this helps. You seem to know how to code, but if you are stuck then let me know.
I found an answer to the problem
instead of
results.Range(commentAddress & results.UsedRange.Rows.Count)
define for e.g. j and iterate it everytime you add new value to the sheet so
results.Range("A" & k & ":" & lastCol & k ).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & k).Value = "BLANK Street"
k = k + 1
from 8 mins to 5 seconds :)
As per my Knowledge, a Sheet to sheet Traverse is always a time taking process.
i would suggest to use an array to save the details of check and then use them while assigning the values.
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = array(Value)
The other recommendation is to identify the blank cells during the array assignment only and store the locations in the separate array. so directly you can iterate through only blank values instead of going through all you 80,000

Resources