Related
I am writing a VBA code on excel using loops to go through 10000+ lines.
Here is an example of the table
And here is the code I wrote :
Sub Find_Matches()
Dim wb As Workbook
Dim xrow As Long
Set wb = ActiveWorkbook
wb.Worksheets("Data").Activate
tCnt = Sheets("Data").UsedRange.Rows.Count
Dim e, f, a, j, h As Range
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
For xrow = 2 To tCnt Step 1
Set e = Range("E" & xrow)
Set f = e.Offset(0, 1)
Set a = e.Offset(0, -4)
Set j = e.Offset(0, 5)
Set h = e.Offset(0, 3)
For Each Cell In Range("E2:E" & tCnt)
If Cell.Value = e.Value Then
If Cell.Offset(0, 1).Value = f.Value Then
If Cell.Offset(0, -4).Value = a.Value Then
If Cell.Offset(0, 5).Value = j.Value Then
If Cell.Offset(0, 3).Value = h.Value Then
If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
Cell.EntireRow.Interior.Color = vbYellow
e.EntireRow.Interior.Color = vbYellow
End If
End If
End If
End If
End If
End If
Next
Next
End Sub
As you can imagine, this is taking a lot of time to go through 10000+ lines and I would like to find a faster solution. There must be a method I don't think to avoid the over looping
Here are the condition :
For each line, if another line anywhere in the file has the exact same
:
Buyer ID (col. E)
`# purchased (col. F)
Product ID (col.A)
Payment (col. J)
Date purchased (col. H)
Then, if the SUM of the Amount (col. L) the those two matching line is
0, then color both rows in yellow.
Note that extra columns are present and not being compared (eg- col. B) but are still important for the document and cannot be deleted to ease the process.
Running the previous code, in my example, row 2 & 5 get highlighted :
This is using nested dictionaries and arrays to check all conditions
Timer with my test data: Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec
Option Explicit
Public Sub FindMatches()
Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12
Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object
Set ur = ThisWorkbook.Worksheets("Data").UsedRange
x = ur
Set d = CreateObject("Scripting.Dictionary")
Set found = CreateObject("Scripting.Dictionary")
Dim r As Long, rId As String, itm As Variant, dupeRows As Object
For r = ur.Row To ur.Rows.Count
rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
If Not d.Exists(rId) Then
Set dupeRows = CreateObject("Scripting.Dictionary")
dupeRows(r) = 0
Set d(rId) = dupeRows
Else
For Each itm In d(rId)
If x(r, L) + x(itm, L) = 0 Then
found(r) = 0
found(itm) = 0
End If
Next
End If
Next
Application.ScreenUpdating = False
For Each itm In found
ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
Next
Application.ScreenUpdating = True
End Sub
Before
After
I suggest a different approach altogether: add a temporary column to your data that contains a concatenation of each cell in the row. This way, you have:
A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A
Then use Excel's conditional formatting on the temporary column, highlighting duplicate values. There you have your duplicated rows. Now it's only a matter of using a filter to check which ones have amounts equal to zero.
You can use the CONCATENATE function; it requires you to specify each cell separately and you can't use a range, but in your case (comparing only some of the columns) it seems like a good fit.
Maciej's answer is easy to implement (if you can add columns to your data without interrupting anything), and I would recommend it if possible.
However, for the sake of answering your question, I will contribute a VBA solution as well. I tested it on dataset that is a bit smaller than yours, but I think it will work for you. Note that you might have to tweak it a little (which row you start on, table name, etc) to fit your workbook.
Most notably, the segment commented with "Helper column" is something you most likely will have to adjust - currently, it compares every cell between A and H for the current row, which is something you may or may not want.
I've tried to include a little commentary in the code, but it's not much. The primary change is that I'm using in-memory processing of an array rather than iterating over a worksheet range (which for larger datasets should be exponentially faster).
Option Base 1
Option Explicit
' Uses ref Microsoft Scripting Runtime
Sub Find_Matches()
Dim wb As Workbook, ws As Worksheet
Dim xrow As Long, tCnt As Long
Dim e As Range, f As Range, a As Range, j As Range, h As Range
Dim sheetArr() As Variant, arr() As Variant
Dim colorTheseYellow As New Dictionary, colorResults() As String, dictItem As Variant
Dim arrSize As Long, i As Long, k As Long
Dim c As Variant
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Data")
ws.Activate
tCnt = ws.UsedRange.Rows.Count
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Read range into an array so we process in-memory
sheetArr = ws.Range("A2:H" & tCnt)
arrSize = UBound(sheetArr, 1)
' Build new arr with "helper column"
ReDim arr(1 To arrSize, 1 To 9)
For i = 1 To arrSize
For k = 1 To 8
arr(i, k) = sheetArr(i, k)
arr(i, 9) = CStr(arr(i, 9)) & CStr(arr(i, k)) ' "Helper column"
Next k
Next i
' Iterate over array & build collection to indicate yellow lines
For i = LBound(arr, 1) To UBound(arr, 1)
If Not colorTheseYellow.Exists(i) Then colorResults = Split(ReturnLines(arr(i, 9), arr), ";")
For Each c In colorResults
If Not colorTheseYellow.Exists(CLng(c)) Then colorTheseYellow.Add CLng(c), CLng(c)
Next c
Next i
' Enact row colors
For Each dictItem In colorTheseYellow
'Debug.Print "dict: "; dictItem
If dictItem <> 0 Then ws.ListObjects(1).ListRows(CLng(dictItem)).Range.Interior.Color = vbYellow
Next dictItem
End Sub
Function ReturnLines(ByVal s As String, ByRef arr() As Variant) As String
' Returns a "Index;Index" string indicating the index/indices where the second, third, etc. instance(s) of s was found
' Returns "0;0" if 1 or fewer matches
Dim i As Long
Dim j As Long
Dim tmp As String
ReturnLines = 0
j = 0
tmp = "0"
'Debug.Print "arg: " & s
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 9) = s Then
j = j + 1
'Debug.Print "arr: " & arr(i, 9)
'Debug.Print "ReturnLine: " & i
tmp = tmp & ";" & CStr(i)
End If
Next i
'If Left(tmp, 1) = ";" Then tmp = Mid(tmp, 2, Len(tmp) - 1)
'Debug.Print "tmp: " & tmp
If j >= 2 Then
ReturnLines = tmp
Else
ReturnLines = "0;0"
End If
End Function
On my simple dataset, it yields this result (marked excellently with freehand-drawn color indicators):
Thanks everybody for your answers,
Paul Bica's solution actually worked and I am using a version of this code now.
But, just to animate the debate, I think I also found another way around my first code, inspired by Maciej's idea of concatenating the cells and using CStr to compare the values and, of course Vegard's in-memory processing by using arrays instead of going through the workbook :
Sub Find_MatchesStr()
Dim AmountArr(300) As Variant
Dim rowArr(300) As Variant
Dim ws As Worksheet
Dim wb As Workbook
Set ws = ThisWorkbook.Sheets("Data")
ws.Activate
Range("A1").Select
rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To rCnt
If i = rCnt Then
Exit For
Else
intCnt = 0
strA = ws.Cells(i, 1).Value
strE = ws.Cells(i, 5).Value
strF = ws.Cells(i, 6).Value
strH = ws.Cells(i, 8).Value
strL = ws.Cells(i, 10).Value
For j = i To rCnt - 1
strSearchA = ws.Cells(j, 1).Value
strSearchE = ws.Cells(j, 5).Value
strSearchF = ws.Cells(j, 6).Value
strSearchH = ws.Cells(j, 8).Value
strSearchL = ws.Cells(j, 10).Value
If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then
AmountArr(k) = ws.Cells(j, 12).Value
rowArr(k) = j
intCnt = intCnt + 1
k = k + 1
Else
Exit For
End If
Next
strSum = 0
For s = 0 To UBound(AmountArr)
If AmountArr(s) <> "" Then
strSum = strSum + AmountArr(s)
Else
Exit For
End If
Next
strAppenRow = ""
For b = 0 To UBound(rowArr)
If rowArr(b) <> "" Then
strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
Else
Exit For
End If
Next
If intCnt = 1 Then
Else
If strSum = 0 Then
For rn = 0 To UBound(rowArr)
If rowArr(rn) <> "" Then
Let rRange = rowArr(rn) & ":" & rowArr(rn)
Rows(rRange).Select
Selection.Interior.Color = vbYellow
Else
Exit For
End If
Next
Else
strvar = ""
strvar = Split(strAppenRow, ",")
For ik = 1 To UBound(strvar)
If strvar(ik) <> "" Then
strVal = CDbl(strvar(ik))
For ik1 = ik To UBound(strvar)
If strvar(ik1) <> "" Then
strVal1 = CDbl(strvar(ik1))
If strVal1 + strVal = 0 Then
Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
Rows(sRange1).Select
Selection.Interior.Color = vbYellow
Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
Rows(sRange).Select
Selection.Interior.Color = vbYellow
End If
Else
Exit For
End If
ik1 = ik1 + 1
Next
Else
Exit For
End If
ik = ik + 1
Next
End If
End If
i = i + (intCnt - 1)
k = 0
Erase AmountArr
Erase rowArr
End If
Next
Range("A1").Select
End Sub
I still have some mistakes (rows not higlighted when they should be), the above code is not perfect, but I thought it'd be OK to give you an idea of where I was going before Paul Bica's solution came in.
Thanks again !
If your data is only till column L, then use below code, I found it is taking less time to run....
Sub Duplicates()
Application.ScreenUpdating = False
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("O2") = "=A2&E2&F2&J2&L2"
Range("P2") = "=COUNTIF(O:O,O2)"
Range("O2:P" & lrow).FillDown
Range("O2:O" & lrow).Copy
Range("O2:O" & lrow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
For i = 1 To lrow
If Cells(i, 16) = 2 Then
Cells(i, 16).EntireRow.Interior.Color = vbYellow
End If
Next
Application.ScreenUpdating = True
Range("O:P").Delete
Range("A1").Select
MsgBox "Done"
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 am working on my computer to automate a quote in Excel with VBA
It consists of finding duplicates so they can be summed.
For example:
I have the following information:
Click here for the Excel file
The range from A2:C4 is a group that it states there are 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A5:C7 is another group that is the same 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A11:C13 is another group but the difference is that for this one are 2 nuts & 2 washer per bolt.
So this wont be sum
This would be the result:
I have the following code where it only looks through all the cells, I can't find a way to make it look in groups or ranges.
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With wSrc
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LastRow)
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, LastColumn), unique:=True
Z = .Cells(.Rows.Count, LastColumn).End(xlUp).Row
LastColumn = LastColumn + 1
.Cells(1, LastColumn).Value = "Total"
.Range(.Cells(2, LastColumn), .Cells(Z, LastColumn)).Formula = _
"=SUMIF(" & rng.Address & "," & .Cells(2, LastColumn - 1).Address(False, False) & "," & rng.Offset(, 1).Address & ")"
End With
With Application
.ScreenUpdating = Truek
.Calculation = xlCalculationAutomatic
End With
End Sub
Click below for the Excel file
Here is an approach that utilizes User Defined Object for the Hardware, and Hardware groups.
We could create more compact code with fewer loops, but, unless there is a significant speed issue, this is probably more readable, and can be more easily adapted to future needs.
We create two class modules (and be sure to rename them as indicated in the code).
One class module is for the hardware items, the second is for the different groups.
The hardware items properties are the description, the weight per item, and the number of items.
The hardware groups properties are a collection of Hardware items, and the Quantity of items in that group.
We then combine the hardware groups into a collection of unique hardware groups.
As the code is written, you could combine in other ways to generate other types of reports.
The results:
Class Module 1
'**Rename: cHardware**
Option Explicit
Private pDescription As String
Private pWt As Double
Private pItemCount As Long
Public Property Get Description() As String
Description = pDescription
End Property
Public Property Let Description(Value As String)
pDescription = Value
End Property
Public Property Get Wt() As Double
Wt = pWt
End Property
Public Property Let Wt(Value As Double)
pWt = Value
End Property
Public Property Get ItemCount() As Long
ItemCount = pItemCount
End Property
Public Property Let ItemCount(Value As Long)
pItemCount = Value
End Property
Class Module 2
'**Rename: cHardwareGrp**
Option Explicit
Private pHW As cHardWare
Private pHWs As Collection
Private pQty As Long
Private Sub Class_Initialize()
Set pHWs = New Collection
End Sub
Public Property Get HW() As cHardWare
Set HW = pHW
End Property
Public Property Let HW(Value As cHardWare)
Set pHW = Value
End Property
Public Property Get HWs() As Collection
Set HWs = pHWs
End Property
Public Function AddHW(Value As cHardWare)
Dim I As Long, J As Long
If pHWs.Count = 0 Then
pHWs.Add Value
Else 'Insert in sorted order
For J = pHWs.Count To 1 Step -1
If pHWs(J).Description <= Value.Description Then Exit For
Next J
If J = 0 Then
pHWs.Add Value, before:=1
Else
pHWs.Add Value, after:=J
End If
End If
End Function
Public Property Get Qty() As Long
Qty = pQty
End Property
Public Property Let Qty(Value As Long)
pQty = Value
End Property
Regular Module
Option Explicit
Sub SummarizeHW()
Dim wsRes As Worksheet, wsSrc As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cHW As cHardWare, colHW As Collection
Dim cHWG As cHardwareGrp, colHWG As Collection
Dim colUniqueHWG As Collection
Dim I As Long, J As Long, K As Long
Dim lQTY As Long
Dim S As String
Dim V As Variant
Dim RE As Object, MC As Object
'Set Source and Results Worksheets and Ranges
Set wsSrc = Worksheets("Hoja1")
Set wsRes = Worksheets("Hoja2")
Set rRes = wsRes.Cells(1, 1)
'Get Source Data
With wsSrc
vSrc = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) _
.Offset(columnoffset:=-1).Resize(columnsize:=3)
End With
'Set up regex to extract number of HW items in description
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.Pattern = "^\((\d+)\)\s*"
.MultiLine = True
End With
'Collect unique list of hardware items
' compute the weight of each single item
Set colHW = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'assumes header row
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHW = New cHardWare
With cHW
S = vSrc(I, 2)
If RE.test(S) = True Then
Set MC = RE.Execute(S)
.ItemCount = CLng(MC(0).submatches(0))
Else
.ItemCount = 1
End If
.Wt = vSrc(I, 3) / lQTY / .ItemCount
.Description = S
colHW.Add cHW, .Description
End With
Next I
On Error GoTo 0
'Collect the Hardware Groups
'HW group starts if there is a "Qty" in column 1
Set colHWG = New Collection
For I = 2 To UBound(vSrc, 1)
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHWG = New cHardwareGrp
Do
With cHWG
.HW = colHW(vSrc(I, 2))
.AddHW .HW
.Qty = lQTY
End With
I = I + 1
If I > UBound(vSrc, 1) Then Exit Do
Loop Until vSrc(I, 1) <> ""
colHWG.Add cHWG
I = I - 1
Next I
'Collect the unique hardware groups
' A group is defined by ALL of the hardware components being identical
' in both type and quantity. Therefore, we can concatenate them as a key
Set colUniqueHWG = New Collection
On Error Resume Next
For I = 1 To colHWG.Count
With colHWG(I)
ReDim V(1 To .HWs.Count)
For J = 1 To UBound(V)
V(J) = .HWs(J).Description
Next J
S = Join(V, "|")
colUniqueHWG.Add colHWG(I), S
Select Case Err.Number
Case 457 'a duplicate so add the QTY
colUniqueHWG(S).Qty = colUniqueHWG(S).Qty + .Qty
Err.Clear
Case Is <> 0 'error stop
Debug.Print Err.Number, Err.Description
End Select
End With
Next I
On Error GoTo 0
'Final Report
'# of columns = 3
'# of rows = sum of the number of HW items in each group + 1 for the header
J = 0
For I = 1 To colUniqueHWG.Count
J = J + colUniqueHWG(I).HWs.Count
Next I
ReDim vRes(0 To J, 1 To 3)
'Column headers
vRes(0, 1) = "Qty"
vRes(0, 2) = "Hardware Description"
vRes(0, 3) = "Weight"
'populate the results array'
K = 1
For I = 1 To colUniqueHWG.Count
With colUniqueHWG(I)
For J = 1 To .HWs.Count
If J = 1 Then vRes(K, 1) = .Qty
vRes(K, 2) = .HWs(J).Description
vRes(K, 3) = .Qty * .HWs(J).Wt * .HWs(J).ItemCount
K = K + 1
Next J
End With
Next I
'Write the results on a new sheet
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.ColumnWidth = 255
With Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Hmmm. I see from your comments that the hardware may not always be in the same order. I will add a sorting routine to our group generation so that will be irrelevant.
EDIT: The AddHW function was modified to insert the HW items in sorted order. Since there should only be a few items, this insertion sort should be adequate.
Taking a different approach.
take advantage of the structure; three lines define it
Put results on a different tab
This input ...
generates this output ...
using this code ...
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Edit:
Summing weights for bolts, nuts, and washers
Checking for case where nuts and washers appear in reverse order
n.b. I am using .UsedRange to find the last row and last column. Other methods are available.
.
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
Dim WSum1 As Double, WSum2 As Double, WSum3 As Double
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
WSum1 = outRng.Cells(iLoop, 3).Value
WSum2 = outRng.Cells(iLoop + 1, 3).Value
WSum3 = outRng.Cells(iLoop + 2, 3).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 1, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 2, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
Else ' check if bolts and washers are in reverse order
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 2, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 1, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 2, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 1, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
outRng.Cells(iLoop, 3).Value = WSum1
outRng.Cells(iLoop + 1, 3).Value = WSum2
outRng.Cells(iLoop + 2, 3).Value = WSum3
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I have this code in one of the part of my script count the data from Column A if the data have duplicate value for 3 consecutive months it will be tag as "Selected" and "Updated"
Output would be like this:
Column A | Column B | Column C | Column D |
243899 | 1/20/2016 | | |
243899 | 2/10/2016 | | |
243899 | 3/15/2016 | Selected | Updated |
Note:
Column B is where the month value
Column C and D is where the data will be tag as "Selected" and "Updated"
I have 3 months of data
My problem is that i'm going to change all the target Column in the example above
Column A to Column T
Column B to Column BS
Column C and D to Column CH and CI
My code:
Public Sub Selection()
Dim file2 As Excel.Workbook
Dim Sheet2 As Worksheet, data(), i&
Dim myRangeColor As Variant, myRangeMonthValue
Dim MstrSht As Worksheet
Dim DataArr As Variant
Dim ColorArr As Variant
Dim MonthCol As Collection
Dim CloseToDate As Date
Dim MaxDate As Date
Dim c As Long
Set Sheet2 = Workbooks.Open(TextBox2.Text).Sheets(1)
'Load Data into Array
DataArr = Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
Find distinct colors
ColorArr = ReturnDistinct(Sheet2.Range("A2:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row))
Remove any values in the arrays third column
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
DataArr(i, 4) = ""
Next i
'Loop Each Color
For c = LBound(ColorArr) To UBound(ColorArr)
Set MonthCol = New Collection
MaxDate = 0
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) Then
'Load the colors months into a collection
On Error Resume Next
MonthCol.Add Month(DataArr(i, 2)), CStr(Month(DataArr(i, 2)))
On Error GoTo 0
'Find Max Date
If DataArr(i, 2) Then
MaxDate = Application.WorksheetFunction.Max(MaxDate, DataArr(i, 2))
End If
End If
Next i
'If the color were found in three or more seperate months then the row with date closest to CloseToDate gets flagged
If MonthCol.Count > 2 Then
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) And DataArr(i, 2) = MaxDate Then
DataArr(i, 3) = "Selected"
DataArr(i, 4) = "Updated"
End If
Next i
End If
Next c
'Print results to sheet
Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr
End Sub
Function ReturnDistinct(InpRng As Range) As Variant
Dim Cell As Range
Dim i As Integer
Dim DistCol As New Collection
Dim DistArr()
'Add all values to collection
For Each Cell In InpRng
On Error Resume Next
DistCol.Add Cell.Value, CStr(Cell.Value)
On Error GoTo 0
Next Cell
'Write collection to array
ReDim DistArr(1 To DistCol.Count)
For i = 1 To DistCol.Count Step 1
DistArr(i) = DistCol.Item(i)
Next i
ReturnDistinct = DistArr
End Function
I got my code here so im not really familiar to this code.. Is it possible to change the column in my script? I've done lots of trial and error on this one i can't seem to figure it out,. Any help, tips or suggestion i would gladly appreciate it!
In my previous comment, I had something in mind as follows. I tested this using columns A,B,C,D, but not using the more widely dispersed columns.
As a side note, I also had some trouble with your WorksheetFunction.Max call - I had to use CDate to get the comparison to work.
Public Sub Selection()
Dim file2 As Excel.Workbook
Dim Sheet2 As Worksheet, data(), i&
Dim myRangeColor As Variant, myRangeMonthValue
Dim MstrSht As Worksheet
Dim DataArr() As Variant
Dim TempArr1 As Variant, TempArr2 As Variant
Dim TempArr3 As Variant, TempArr4 As Variant
Dim ColorArr As Variant
Dim MonthCol As Collection
Dim CloseToDate As Date
Dim MaxDate As Date
Dim c As Long
Dim nRows As Long, nCols As Long
Dim iLoop As Long
' Set Sheet2 = Workbooks.Open(TextBox2.Text).Sheets(1)
Set Sheet2 = Sheets("Sheet2")
'Load Data into Array
' DataArr = Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr1 = Sheet2.Range("T2:T" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr2 = Sheet2.Range("BS2:BS" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr3 = Sheet2.Range("CH2:CH" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
TempArr4 = Sheet2.Range("CI2:CI" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row)
nRows = UBound(TempArr1)
nCols = 4
ReDim Preserve DataArr(1 To nRows, 1 To nCols)
For iLoop = 1 To nRows - 1
DataArr(iLoop, 1) = TempArr1(iLoop, 1)
DataArr(iLoop, 2) = TempArr2(iLoop, 1)
DataArr(iLoop, 3) = TempArr3(iLoop, 1)
DataArr(iLoop, 4) = TempArr4(iLoop, 1)
Next iLoop
'Find distinct colors
ColorArr = ReturnDistinct(Sheet2.Range("A2:A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row))
'Remove any values in the arrays third column
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
DataArr(i, 3) = ""
Next i
'Loop Each Color
For c = LBound(ColorArr) To UBound(ColorArr)
Set MonthCol = New Collection
MaxDate = 0
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) Then
'Load the colors months into a collection
On Error Resume Next
MonthCol.Add Month(DataArr(i, 2)), CStr(Month(DataArr(i, 2)))
On Error GoTo 0
'Find Max Date
If DataArr(i, 2) > 0 Then
MaxDate = Application.WorksheetFunction.Max(CDate(MaxDate), CDate(DataArr(i, 2)))
End If
End If
Next i
'If the color were found in three or more seperate months then the row with date closest to CloseToDate gets flagged
If MonthCol.Count > 2 Then
For i = LBound(DataArr, 1) To UBound(DataArr, 1)
If DataArr(i, 1) = ColorArr(c) And DataArr(i, 2) = MaxDate Then
DataArr(i, 3) = "Selected"
DataArr(i, 4) = "Updated"
End If
Next i
End If
Next c
'Print results to sheet
'Sheet2.Range("A2:D" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row) = DataArr
For iLoop = 1 To nRows - 1
TempArr1(iLoop, 1) = DataArr(iLoop, 1)
TempArr2(iLoop, 1) = DataArr(iLoop, 2)
TempArr3(iLoop, 1) = DataArr(iLoop, 3)
TempArr4(iLoop, 1) = DataArr(iLoop, 4)
Next iLoop
Sheet2.Range("T2:" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr1
Sheet2.Range("BS2:BS" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr2
Sheet2.Range("CH2:CH" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr3
Sheet2.Range("CI2:CI" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row).Value2 = TempArr3
End Sub
Not sure how to put this in words, but basically macro is run from the sheet1 of WorkBook1, and it should produce one like sheet1 of WorkBook2. (WB2 Sheet1 is empty)
The trick is that macro should only work with user selected range.
So if A1:A7 is selected, it will only grab data from A1:A7 to last column with data
If nothing is selected then exit sub with msgbox or something
Order/sort does not matter as long as it merges XYs duplicates and group respective fruits together.
A B => A B C
1 XY3 Apple => 1 H XY1
2 XY1 Orange => 2 D Orange
3 XY3 Banana => 3 H XY2
4 XY3 Banana => 4 D Orange
5 XY3 Peach => 5 H XY3
6 XY4 Orange => 6 D Apple
7 XY2 Orange => 7 D Banana
8 XY7 Apple => 8 D Banana
=> 9 D Peach
=> 10 H XY4
=> 11 D Orange
[WB1 Sheet1] => [WB2 Sheet1]
This might be difficult but I am desperately seeking for help.
Thank you so much!
I set up this macro to copy to sheet2 of the same workbook. To save to a new workbook just update the following line of code with your workbook name instead of activeworkbook.
Set sheetB = ActiveWorkbook.Sheets("Sheet2")
Started with the following data in sheet 1 and a blank sheet 2:
Select A1 to A8 and run this macro:
Sub CopyAndFormat()
If IsEmpty(Selection) Then
MsgBox ("Empty Cell")
Exit Sub
End If
Dim sheet As Worksheet
Set sheetA = ActiveWorkbook.Sheets("Sheet1")
Set sheetB = ActiveWorkbook.Sheets("Sheet2")
Dim FirstRow As Long, LastRow As Long
FirstRow = Selection.Rows(1).Row
LastRow = Selection.Rows.Count + FirstRow - 1
'First Column
Dim rngA As Range
Set rngA = Range("A" & FirstRow & ":A" & LastRow)
Dim datA As Variant
datA = rngA
Dim i As Long
'Second Column Match
Dim rngB As Range
Set rngB = Range("B" & FirstRow & ":B" & LastRow)
Dim datB As Variant
datB = rngB
Dim j As Long
Dim resultA As Variant
Dim resultB As Variant
Dim rng As Range
Dim rngr As Range
Set rng = sheetB.Range("A1:A" & LastRow + 100)
Set rngr = sheetB.Range("B1:B" & LastRow + 100)
resultA = rng
resultB = rngr
'Store duplicates
Dim rngString As String
rngString = "empty"
Dim match As Boolean
match = False
Dim cntr As Integer
cntr = 1
'First Column loop
For i = LBound(datA, 1) To UBound(datA, 1)
If rngString <> "empty" Then
If Not Intersect(Range("A" & i), Range(rngString)) Is Nothing Then
GoTo nextloop
End If
End If
'Second Column Loop
For j = LBound(datA, 1) + i To UBound(datA, 1)
If i <> j And datA(i, 1) = datA(j, 1) And Not IsEmpty(datA(j, 1)) And Not IsEmpty(datA(i, 1)) Then
'copy position of duplicate in variant
If rngString = "empty" Then
match = True
resultA(cntr, 1) = datA(i, 1)
resultB(cntr + 1, 1) = datB(i, 1)
resultB(cntr + 1, 1) = datB(i, 1)
resultB(cntr + 2, 1) = datB(j, 1)
rngString = "A" & i & ",A" & j
cntr = cntr + 2
Else
resultB(cntr + 1, 1) = datB(j, 1)
cntr = cntr + 1
rngString = rngString & "," & "A" & j
End If
End If
Next
If match = False Then
resultA(cntr + 1, 1) = datA(i, 1)
resultB(cntr + 2, 1) = datB(i, 1)
cntr = cntr + 2
End If
match = False
'cntr = cntr + 1
nextloop:
Next
rng = resultA
rngr = resultB
End Sub
You'll get the following on sheet2:
Sorry the code is a little messy and I hate using goto's but this will get you started.