I am writing a script to print in a message box, the cell value and repetitive number counts from 1-5.
Currently, I have a for loop that counts the total number of rows I have in my spreadsheet. I am unsure of how to add another for loop (nested for loop) to call the program to add 1 to 5 to the first 5 rows, and restart at 1 to 5 again at the 6th row, and so on.
For example,
If values in cells A1 to A10 are "Apple" respectively, I want to concetenate numbers from 1 to 5 such that I get the results below:
A1 = "Apple1"
A2 = "Apple2"
A3 = "Apple3"
A4 = "Apple4"
A5 = "Apple5"
A6 = "Apple1" 'it starts from 1 again
A7 = "Apple2"
and so on
Below is my sample code:
Option Explicit
Sub appendCount()
Dim q, i, rowStart, rowEnd , rowNum, LR as Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).Count
For q = 1 To rowNum Step 1
If Not IsNull(Range("A" & q)) Then
For i = 1 to 5
MsgBox Range("A" & q).Value & i
Next i
End If
Next q
End Sub
Any help would be greatly appreciated!
I believe the following will do what you expect, it will look at the values on Column A and add the count to them on Column B:
Option Explicit
Sub appendCount()
Dim LR As Long, rownumber As Long, counter As Long
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
counter = 0
LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For rownumber = 1 To LR Step 1
If Not IsEmpty(ws.Range("A" & rownumber)) Then
counter = counter + 1
If counter = 6 Then counter = 1
ws.Range("B" & rownumber).Value =ws.Range("A" & rownumber).value & counter
End If
Next rownumber
End Sub
IsNull() on a cell will always return False. Replace IsNull by IsEmpty,
or use someCell <> "".
See https://stackoverflow.com/a/2009754/78522
Working with arrays will be faster. Also, mod will fail with large numbers so the below is written to handle large numbers. The point to start renumbering is also put into a constant to allow easy access for changing. Code overall is thus more flexible and resilient.
Option Explicit
Public Sub AddNumbering()
Dim arr(), i As Long, lastRow As Long, index As Long
Const RENUMBER_AT = 6
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Select Case lastRow
Case 1
ReDim arr(1, 1): arr(1, 1) = .Range("A1").Value
Case Else
arr = .Range("A1:A" & lastRow).Value
End Select
index = 1
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 1) <> vbNullString Then
If i - (CLng(i / RENUMBER_AT) * RENUMBER_AT) <> 0 And i <> 1 Then
index = index + 1
Else
index = 1
End If
arr(i, 1) = arr(i, 1) & CStr(index)
End If
Next
.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
I understand your question is values in cells A1 to A10 are "Apple" respectively, you want to content Numbers from 1 to 5, then A6 to A10 content Numbers are also from 1 to 5.
This my test code, you can try it:
Option Explicit
Sub appendCount()
Dim q, i, cou, rowStart, rowEnd, rowNum, LR As Long
LR = Cells(Rows.count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).count
cou = 1
For q = 1 To rowNum Step 1
If Not IsNull(Range("A" & q)) Then
For i = 1 To 5
MsgBox Range("A" & q).Value & cou
cou = cou + 1
If cou = 6 Then
cou = 1
End If
Next i
End If
Next q
End Sub
Your declaration is wrong, despite what you might expect these variables are NOT declared as Long but as Variant: q, i, rowStart, rowEnd , rowNum you must include the type for each variable separately.
This code should do the trick for you:
Sub appendCount()
Dim q As Long, LR As Long, rowNum As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).Count
For q = 1 To rowNum Step 1
If Not Len(Range("A" & q).Value) = 0 Then
If q Mod 5 = 0 Then
MsgBox Range("A" & q).Value & 5
Else
MsgBox Range("A" & q).Value & (q Mod 5)
End If
End If
Next q
End Sub
Sub appendCount()
Dim q, c, i, rowStart, rowEnd, rowNum, LR As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
rowNum = Range("A1:A" & LR).Count
c = 1
For q = 1 To rowNum Step 1
If Not IsEmpty(Range("A" & q)) Then
If (c Mod 6) <> 0 Then
Range("B" & q).Value = Range("A" & q).Value & (c Mod 6)
Else
c = c + 1
Range("B" & q).Value = Range("A" & q).Value & (c Mod 6)
End If
End If
c = c + 1
Next q
End Sub
This would do it:
Sub Loops()
Dim i As Long, iMultiples As Long, iMultiple As Long
iMultiples = WorksheetFunction.Ceiling_Math(Cells(Rows.Count, 1).End(xlUp).Row, 5, 0) ' this rounds up to the nearest 5 (giving the number of multiples
For iMultiple = 1 To iMultiples
For i = 1 To 5
If Not IsNull(Range("A" & i).Value) Then Range("A" & i).Value = "Apple" & i 'This can be tweaked as needed
Next
Next
End Sub
I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub
First, I'd like to apologize for this poor question and I hope it doesn't upset anyone here. Since I'm not that good at speaking English to convey my request, so please have a look to the cited links in order to get a clear explanation to this question.
I'm trying to find the solution to this question of mine. I started my attempt by searching for the same number in column A and column B (Debit and Credit). I used the looping-trough-array method to do it instead of employing the Find function like this question since I think it's faster.
Suppose that I have the following set data in Sheet1 and start from row 1 column A:
D e b i t Cr e d i t
20 13
14 13
13 14
14 17
19 19
11 20
17 14
20 12
19 19
20 15
20 12
13 11
12 19
13 20
19 19
20 11
11 16
10 16
19 19
20 11
Now, I'd like to process the data set above to something like this:
Basically, I need to find the same value of debit and credit in a specific row and match it with debit and credit in another row. Column C (Row) indicates the matched values. For example, the debit value in row 2 match with the credit value in row 15 and vice-versa. And numbers in column D (ID Match) are the label numbers to indicate the order of the matched data that's found first. This is my code in an attempt to implement the task:
Public i As Long, j As Long, k As Long, Last_Row As Long
Public DC, Row_Data, ID_Match
Sub Quick_Match()
T0 = Timer
k = 0
Last_Row = Cells(Rows.Count, "A").End(xlUp).Row
ReDim DC(1 To Last_Row - 1, 1 To 2)
ReDim Row_Data(1 To Last_Row - 1, 1 To 1)
ReDim ID_Match(1 To Last_Row - 1, 1 To 1)
DC = Range("A2:B" & Last_Row)
For i = 1 To Last_Row - 1
If DC(i, 1) <> "" Then
k = k + 1
For j = 1 To Last_Row - 1
If DC(i, 1) <> DC(i, 2) Then
If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
Call Row_Label
Exit For
Else
Row_Data(i, 1) = "No Match"
End If
Else
If i <> j Then
If DC(i, 1) = DC(j, 1) And DC(i, 2) = DC(j, 2) Then
Call Row_Label
Exit For
Else
Row_Data(i, 1) = "No Match"
End If
End If
End If
Next j
End If
If Row_Data(i, 1) = "No Match" Then
k = k - 1
End If
Next i
Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
InputBox "The runtime of this program is ", "Runtime", Timer - T0
End Sub
Sub Row_Label()
Row_Data(i, 1) = j + 1
ID_Match(i, 1) = k
Row_Data(j, 1) = i + 1
ID_Match(j, 1) = k
DC(i, 1) = ""
DC(i, 2) = ""
DC(j, 1) = ""
DC(j, 2) = ""
End Sub
Though it's a bit slow on its performance, but it works fine. It completes in about 25 seconds on my machine for processing 10,000 rows of data (the data set file can be downloaded on this link for testing the running time of your code and mine). So I'm wondering if there is a more effective way for doing this. Could anyone come up with either a shorter version or a quicker version? Please do share your attempt.
Our ID's don't are different because I don't search ahead in the list for a match. I iterate over the list one time adding keys to a dictionary. If a find a key already exists that matches your criteria assign the new ID and row numbers.
Let me know if this meets your criteria.
Sub DebitCreditCrossMatch()
Dim dictKeys As Object, dictRows As Object
Dim DebitKey As String, CreditKey As String
Dim arrDebit, arrCredit, arrMatchRow, arrMatchID, items, keys
Dim ID As Long, rw As Long, x As Long, lastRow As Long
lastRow = Cells(Rows.count, "A").End(xlUp).Row
arrDebit = Range("A1", "A" & lastRow).Value
arrCredit = Range("B1", "B" & lastRow).Value
arrMatchRow = Range("C1", "C" & lastRow).Value
arrMatchID = Range("D1", "D" & lastRow).Value
Set dictKeys = CreateObject("Scripting.Dictionary")
For x = 2 To lastRow
arrMatchRow(x, 1) = "No Match"
arrMatchID(x, 1) = "No Match"
DebitKey = arrDebit(x, 1) & ":" & arrCredit(x, 1)
CreditKey = arrCredit(x, 1) & ":" & arrDebit(x, 1)
If dictKeys.Exists(CreditKey) Then
Set dictRows = dictKeys(CreditKey)
items = dictRows.items
keys = dictRows.keys
rw = CLng(items(0))
ID = ID + 1
arrMatchRow(x, 1) = rw
arrMatchRow(rw, 1) = x
arrMatchID(x, 1) = ID
arrMatchID(rw, 1) = ID
dictRows.Remove keys(0)
If dictRows.count = 0 Then dictKeys.Remove CreditKey
ElseIf dictKeys.Exists(DebitKey) Then
Set dictRows = dictKeys(DebitKey)
dictRows.Add x, x
Else
Set dictRows = CreateObject("Scripting.Dictionary")
dictRows.Add x, x
dictKeys.Add DebitKey, dictRows
End If
Next
Range("C1", "C" & lastRow).Value = arrMatchRow
Range("D1", "D" & lastRow).Value = arrMatchID
Set dictKeys = Nothing
Set dictRows = Nothing
End Sub
I reworked my previous answer introducing a second loop; so that our ID numbers will match.
Sub DebitCreditCrossMatch()
Dim dictKeys As Object, dictRows As Object
Dim DebitKey As String, CreditKey As String
Dim arrDebit, arrCredit, items, keys
Dim arrMatchRow(), arrMatchID()
Dim ID As Long, rw As Long, x As Long, lastRow As Long
lastRow = Cells(Rows.count, "A").End(xlUp).Row
arrDebit = Range("A1", "A" & lastRow).Value
arrCredit = Range("B1", "B" & lastRow).Value
ReDim arrMatchID(lastRow - 2)
ReDim arrMatchRow(lastRow - 2)
Set dictKeys = CreateObject("Scripting.Dictionary")
For x = 2 To lastRow
DebitKey = arrDebit(x, 1) & ":" & arrCredit(x, 1)
CreditKey = arrCredit(x, 1) & ":" & arrDebit(x, 1)
If dictKeys.Exists(CreditKey) Then
Set dictRows = dictKeys(CreditKey)
items = dictRows.items
keys = dictRows.keys
rw = CLng(items(0))
arrMatchRow(x - 2) = rw
arrMatchRow(rw - 2) = x
dictRows.Remove keys(0)
If dictRows.count = 0 Then dictKeys.Remove CreditKey
ElseIf dictKeys.Exists(DebitKey) Then
Set dictRows = dictKeys(DebitKey)
dictRows.Add x, x
Else
Set dictRows = CreateObject("Scripting.Dictionary")
dictRows.Add x, x
dictKeys.Add DebitKey, dictRows
End If
Next
For x = 0 To lastRow - 2
If Not IsEmpty(arrMatchRow(x)) And IsEmpty(arrMatchID(x)) Then
rw = arrMatchRow(x) - 2
arrMatchRow(rw) = x + 2
ID = ID + 1
arrMatchID(x) = ID
arrMatchID(rw) = ID
Else
If IsEmpty(arrMatchRow(x)) Then
arrMatchRow(x) = "No Match"
End If
End If
Next
Range("C2", "C" & lastRow).Value = WorksheetFunction.Transpose(arrMatchRow)
Range("D2", "D" & lastRow).Value = WorksheetFunction.Transpose(arrMatchID)
Set dictKeys = Nothing
Set dictRows = Nothing
End Sub
Assuming there are no duplicated in the Credit-Debit pairs you could use the following methods in a separate module calling matchCreditDebit() and adjusting the ranges in the initialization phase as needed:
Option Explicit
Public Sub matchCreditDebit()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim debit As Range, credit As Range, match As Range, rows As Long
rows = ws.UsedRange.rows.Count
Set credit = ws.Range("A1:A" & rows)
Set debit = ws.Range("B1:B" & rows)
Set match = ws.Range("C1:C" & rows)
match.Offset(1).Clear 'delete previous matched, start with clean slate, offset used to preserve header
Dim foundRanges As Collection, i As Long, r As Range
For i = 2 To rows
If Len(ws.Cells(i, match.Column).Value) = 0 _
And Len(ws.Cells(i, credit.Column).Value) > 0 Then 'check if match is already found and credit has value
Set foundRanges = FindAllInRange(debit, credit.Cells(i, 1).Value) 'first sift, find matching debit with a credit value
If Not foundRanges Is Nothing Then
For Each r In foundRanges
Debug.Print r.Address, ws.Cells(r.Row, credit.Column).Value
If ws.Cells(r.Row, credit.Column).Value = ws.Cells(i, debit.Column) Then 'second sift, match for found credit in debit
ws.Cells(r.Row, match.Column).Value = i
End If
Next r
End If
End If
Next i
End Sub
Public Function FindAllInRange( _
ByRef searchRange As Range, _
ByVal FindWhat As Variant _
) As Collection
Dim result As Collection
Set result = New Collection
Dim nextFound As Range
Set nextFound = searchRange.Cells(searchRange.rows.Count, 1)
Do
Set nextFound = searchRange.Find( _
What:=FindWhat, _
After:=nextFound, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
If nextFound Is Nothing Then Exit Do
If collectionContainsRange(result, nextFound) Then Exit Do
result.Add nextFound, nextFound.Address
Loop While True
Set FindAllInRange = result
End Function
Private Function collectionContainsRange(ByRef result As Collection, ByRef rng As Range) As Boolean
collectionContainsRange = False
Dim r As Range
For Each r In result
If StrComp(r.Address, rng.Address, vbTextCompare) = 0 Then
collectionContainsRange = True
Exit Function
End If
Next r
End Function
Generally what this does is find the ranges that match the first criteriaon and put them into a collection and from those sift out the ones that match the second criteria. However if there are duplicate pairs the last found reverse pair will be entered as ref.
Edit comments: Starting inner loop without lctrRow will not do back-checking. Reinstated original code.
Sub test()
'/ Assuming that on Sheet1 starting at A1, four headers are : Debit Credit Row ID Match
Dim lCtrRow As Long
Dim lCtrRow2 As Long
Dim lmatchCount As Long
Dim arrResult
arrResult = Sheet1.UsedRange
'/ Loop through first column Rows
For lCtrRow = LBound(arrResult) To UBound(arrResult)
lmatchCount = 0
arrResult(lCtrRow, 3) = "No Match"
'/ Re-Loop but this time match if A&B = B&A
For lCtrRow2 = LBound(arrResult) + 1 To UBound(arrResult)
If arrResult(lCtrRow, 1) & arrResult(lCtrRow, 2) = arrResult(lCtrRow2, 2) & arrResult(lCtrRow2, 1) Then
'/ If no match then only put down the row number. Avoids overwriting.
If arrResult(lCtrRow, 3) = "No Match" Then
arrResult(lCtrRow, 3) = lCtrRow2
End If
'/ Keep track of no. matches found.
lmatchCount = lmatchCount + 1
arrResult(lCtrRow, 4) = lmatchCount
End If
Next
Next
'/ Dump the processed result back on another sheet
Sheet2.Range("a1").Resize(UBound(arrResult), UBound(arrResult, 2)) = arrResult
End Sub
This worked for me:
Sub Matching()
Dim rng, arr, r1 As Long, r2 As Long, nR As Long
Dim sortId As Long, rwTrack(), s1, s2
'get the input range
With Range("a1").CurrentRegion 'assumes no blank columns/rows
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
arr = rng.Value
nR = UBound(arr, 1)
ReDim rwTrack(1 To nR) 'for matching row numbers to sortId
' (should be more like nR/2 but lazy...)
sortId = 1
For r1 = 1 To nR
For r2 = r1 + 1 To nR
If arr(r1, 1) = arr(r2, 2) And arr(r1, 2) = arr(r2, 1) Then
s1 = arr(r1, 4)
s2 = arr(r2, 4)
If Len(s1) = 0 And Len(s2) = 0 Then
'new match - assign new Id
arr(r1, 4) = sortId
arr(r2, 4) = sortId
rwTrack(sortId) = r1 & "," & r2 'capture the rows
sortId = sortId + 1
Else
'already matched: copy the existing Id and track rows
If Len(s1) > 0 And Len(s2) = 0 Then
arr(r2, 4) = s1
rwTrack(s1) = rwTrack(s1) & "," & r2
End If
If Len(s2) > 0 And Len(s1) = 0 Then
arr(r1, 4) = s2
rwTrack(s2) = rwTrack(s2) & "," & r1
End If
End If
End If
Next r2
Next r1
'populate all of the matched row numbers
For r1 = 1 To nR
If arr(r1, 4) <> "" Then arr(r1, 3) = rwTrack(arr(r1, 4))
Next r1
'dump the data back
Range("a1").Offset(1, 0).Resize(nR, UBound(arr, 2)).Value = arr
End Sub
Before and after:
To speed up the matching, can improve thru Algorithm.
Assuming your code are working fine.
1) We can sort Column A then Column B, therefore, your data will be like this
Row A B
2 20 13
3 20 12
4 20 11
.
.
.
998 13 20
999 12 20
1000 11 20
.
.
.
2) While looping Debit column to find the first value 20 within Credit column might have a very huge gap. We can then add in application.Match(20,Range("B:B"),0) to find out the row to start the loop.
Base on above assumption, we can reduce about 1000 times of loop. (in real case, it could be more/less). Application.Match() is lot more faster than looping one by one.
3) Exit the loop, when Credit value is less than Debit value, because we have sort the data in sequence, we can assume there have no possible match, when Credit < Debit.
4) While the use Application.ScreenUpdating = False, can increase the processing speed.
5) Without touch the original data, also can use Application.Match to reduce row by row loop.
Assume, you have 10K records,
first set searchRng as C1:C10000, then match to find the row of the first Debit value (20, base on yr photo),
then we found matched record on Row 7, check if the record match both Debit & Credit, if not reduce the resize of searchRng to C8:C10000 then keep repeating the logic
Sub Match ()
For nRow = 2 to lastRow 'Loop for each row in Column A
set searchRng = Range("C1:C10000")
debitVal = Cells(nRow, "B")
Do until searchRng is Nothing
If IsError(Application.Match(debitVal, searchRng, 0)) then
'No Match
Exit Do
Else
N = Application.Match(debitVal, searchRng, 0)
'Do something to check if Record match, and assign ID Match
If IsRecordMatched Then
'Assign ID
'Matching Range - Cells(nRow,"B")
'Matched Range - Cells(searchRng.Cells(1).Offset(N,0).Rows, "B")
Else
'Resize the searchRng
nSize = searchRng.Cells.Count - (N + 1)
if nSize < 1 then Exit Do
set searchRng = searchRng.Resize(nSize,1)
set searchRng = searchRng.Offset(N + 1,0)
End If
End If
Loop
Next nRow
End Sub
Above code not tested. Please take it as reference.
Improvement
The following code completes less than 2.4 seconds on average. It's twice faster than the previous one and also shorter.
Sub Quick_Match()
Dim i As Long, j As Long, k As Long, Last_Row As Long
Dim DC, Row_Data, ID_Match
Last_Row = Cells(Rows.Count, "A").End(xlUp).Row
ReDim DC(1 To Last_Row - 1, 1 To 2)
ReDim Row_Data(1 To Last_Row - 1, 1 To 1)
ReDim ID_Match(1 To Last_Row - 1, 1 To 1)
DC = Range("A2:B" & Last_Row).Value2
For i = 1 To Last_Row - 2
If DC(i, 1) <> vbNullString Then
k = k + 1
For j = i + 1 To Last_Row - 1
If DC(j, 2) <> vbNullString Then
If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
Row_Data(i, 1) = j + 1: ID_Match(i, 1) = k
Row_Data(j, 1) = i + 1: ID_Match(j, 1) = k
DC(i, 1) = vbNullString: DC(i, 2) = vbNullString
DC(j, 1) = vbNullString: DC(j, 2) = vbNullString
Exit For
End If
End If
Next j
End If
If Row_Data(i, 1) = vbNullString Then
Row_Data(i, 1) = "No Match": k = k - 1
End If
Next i
Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
End Sub
[Old answer] Some progress. The following code completes less than 5.2 seconds on average for processing 10,000 rows of data on my machine. Not only is faster, but it's also a bit shorter than the previous one. I changed the looping algorithm to improve its performance. I also use some speedup tricks like using .Value2rather than the default property (.Value) makes Excel do less processing and assigning vbNullString instead of Zero Length String ("") to the elements of the array that has found its match or labeled "No Match" so that the loop procedure won't process it again.
Public i As Long, j As Long, k As Long, Last_Row As Long
Public DC, Row_Data, ID_Match
Sub Quick_Match()
T0 = Timer
k = 0
Last_Row = Cells(Rows.Count, "A").End(xlUp).Row
ReDim DC(1 To Last_Row - 1, 1 To 2)
ReDim Row_Data(1 To Last_Row - 1, 1 To 1)
ReDim ID_Match(1 To Last_Row - 1, 1 To 1)
DC = Range("A2:B" & Last_Row).Value2
For i = 1 To Last_Row - 1
If DC(i, 1) <> vbNullString Then
k = k + 1
For j = 1 To Last_Row - 1
If DC(j, 2) <> vbNullString Then
If DC(i, 1) <> DC(i, 2) Then
If DC(i, 1) = DC(j, 2) And DC(i, 2) = DC(j, 1) Then
Call Row_Label
Exit For
End If
Else
If i <> j Then
If DC(i, 1) = DC(j, 1) And DC(i, 2) = DC(j, 2) Then
Call Row_Label
Exit For
End If
End If
End If
End If
Next j
End If
If Row_Data(i, 1) = vbNullString Then
Row_Data(i, 1) = "No Match"
DC(i, 2) = vbNullString
k = k - 1
End If
Next i
Range("C2:C" & Last_Row) = Row_Data
Range("D2:D" & Last_Row) = ID_Match
InputBox "The runtime of this program is ", "Runtime", Timer - T0
End Sub
Sub Row_Label()
Row_Data(i, 1) = j + 1
ID_Match(i, 1) = k
Row_Data(j, 1) = i + 1
ID_Match(j, 1) = k
DC(i, 2) = vbNullString
DC(j, 1) = vbNullString
DC(j, 2) = vbNullString
End Sub
I have a macro that runs 4 formulas.
Sub Kit()
Dim ws As Worksheet
Dim LastRow As Long
Dim i, n, x As Integer
Set ws = ActiveWorkbook.Sheets("Report KIT (2)")
ws.Select
LastRow = Sheets("Report KIT (2)").Range("A" & Sheets("Report KIT (2)").Rows.Count).End(xlUp).Row
For i = 3 To LastRow
On Error Resume Next
If Range("BR" & i) >= Range("AM" & i) Then
Range("BS" & i) = "C"
Else: Range("BS" & i) = "GA + C"
End If
Next i
For i = 3 To LastRow
On Error Resume Next
Range("BT" & i).Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-1]=""C"",(RC[-3]/SUMIFS(C[-3],C[-6],RC[-6]))*(VLOOKUP('Report KIT (2)'!RC[-6],GA_C!C[-71]:C[-68],4,0)),SUM((RC[-3]/SUMIFS(C[-3],C[-6],RC[-6]))*(VLOOKUP('Report KIT (2)'!RC[-6],GA_C!C[-71]:C[-68],4,0)),(RC[-3]/SUMIFS(C[-3],C[-6],RC[-6],C[-1],""GA + C""))*(VLOOKUP('Report KIT (2)'!RC[-6],GA_C!C[-71]:C[-69],3,0))))"
Next i
For i = 3 To LastRow
On Error Resume Next
Range("BU" & i).Select
ActiveCell.FormulaR1C1 = "=RC[-4]+RC[-1]"
Next i
For i = 3 To LastRow
On Error Resume Next
Range("BV" & i).Select
ActiveCell.FormulaR1C1 = "=(RC[-2]+RC[-5])*0.13"
Next i
End Sub
I would like to modify it in order to repeat the same calculation, but after each full circle of all 4 formulas to move starting columns: BS; BT; BU; BV in 4 cells forward (so on the next circle they become BW; BX; BY; BZ, then on the 3rd run CA; CB; CC; CD etc.) And i would like to loop it for 11 times. Can anyone help with it, please?
You can try the below. I have referenced the columns with numbers, using the cells property. After each formula loop the column increments by 1.
Also remember that if you declare variables like this Dim i, n, x As Integer it will only declare x as an integer, i and n will be declared as variants.
Option Explicit
Sub Kit()
Dim ws As Worksheet
Dim LastRow As Long
Dim i As Integer, n As Integer, x As Integer, j As Integer, mcol As Integer
Set ws = ActiveWorkbook.Sheets("Report KIT (2)")
ws.Select
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
mcol = 71
For j = 1 To 11
For i = 3 To LastRow
On Error Resume Next
If Cells(i, mcol - 1) >= Range("AM" & i) Then
Cells(i, mcol) = "C"
Else
Cells(i, mcol) = "GA + C"
End If
Next i
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "D" ''formula using mcol
Next i
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "E" ''formula using mcol
Next i
mcol = mcol + 1
For i = 3 To LastRow
On Error Resume Next
Cells(i, mcol) = "F" ''formula using mcol
Next i
mcol = mcol + 1
Next j
End Sub
You need 2 new loops and change the range method to cells method
For mainLoop = 1 To 11
For newLoop = 0 To 4
'demonstration of the change
'in EDIT added the (newLoop * 4) * mainLoop into the column increment
For i = 3 To LastRow
If Cells(i, 70 + (newLoop * 4) * mainLoop ) >= Cells(i, 39) Then 'change the right part of compare >= as needed
Cells(i, 71 + (newLoop * 4) * mainLoop ) = "C"
Else: Cells(i, 71 + (newLoop * 4)*mainLoop ) = "GA + C"
End If
Next i
'repeat similar change in all other loops
For i = 3 To LastRow
'...
Next i
For i = 3 To LastRow
'...
Next i
For i = 3 To LastRow
'...
Next i
Next newLoop
Next mainLoop
Edit 2
After correct comments from the author of the question...This should do the trick.
For mainLoop = 0 To 10
For newLoop = 0 To 3 'changed to 3
For i = 3 To LastRow
If Cells(i, 70 + newLoop * 4 + 16 * mainLoop) >= Cells(i, 39) Then 'change the right part of compare >= as needed
Cells(i, 71 + newLoop * 4 + 16 * mainLoop) = "C"
Else: Cells(i, 71 + newLoop * 4 + 16 * mainLoop) = "GA + C"
End If
Next i
'repeat similar change in all other loops
For i = 3 To LastRow
'...
Next i
'...
Next newLoop
Next mainLoop