Windows 10
Excel pro Plus 2019
I am getting a Run-Time: error 13 - Data Mismatch when running my code below with excel VBA editor highlighting the two rows
I wanted to achieve the fastest possible method using VBA as using a formula (which I explain further down) takes excel over 6If arrData(i, 1) = arrData(i + 1, 1) And arrData(i, 2) = arrData(i + 1, 2) And _ arrData(i, 9) = arrData(i + 1, 9) And arrData(i, 10) = arrData(i + 1, 10) Then
minutes to run on a spreadsheet with currently 91,000 rows and when live, this figure will only increase.
What is it I am running the Sub on.
On a worksheet called "DATA SORT" with a header row.
There is data in Columns A to J.
For the sake of this explination, a number of rows with matching data in specific columns are essentually a data set for one product.
The defining Columns where matching data will occur are Columns A, B, I2 and J.
The data in Columns C, D, E, F, and G, will not match and will vary.
This is why I am using columns A, B, I2 and J to make the matches.
What is it that I am trying to do.
Where the data (or value) in Columns A, B, I2 and J match with the next row down, look at the row after that, if it also matches then
continue until the next row does not match.
*In essence that is defining the a set or group of rows that relate to each other because of the matches in Columns A, B, I2 and J.
For that set or group of "matching" rows, look at the data or values in the rows of Column E.
*Column E value will always be a number, either a 1 or 2 or a mix of 1's and 2's.
If the data/values in all of the cells are all 1's then in column K, in the last row of the matching data set enter the text "YES"
If the data/values in all of the cells are all 2's then in column K, in the last row of the matching data set enter the text "NO"
If the data/values in all of the cells are a mix or 1's and 2' then in column K, in the last row of the matching data set enter the text "MAYBE"
Then look at the row that did not match with the one above it, and where the data (or value) in Columns A, B, I2 and J match with the next row down, look at the row after that, if it also matches then continue down until the next row does not match.
*This defines the next Data Set (product family) repeat the process described above.
Then move on to the next, and then the next all of the way down the work sheet.
I am mindful to not confuse my description but I was origianlly using a formula to do this which was entered by VBA and copied down column K
until the last used row.
This was fine when the number of rows was fairly small, say around 1000, maybe 2000, but now there are 91,000 and this will get bigger, when pasted in and copied down by VBA it takes over 6 minutes to run
and the pages of the work sheet go dim - not good really.
I include it here so you might be able to see what I am trying to replace but this VBA was my attempt to replace the formula below with something faster.
My thinking was that loading as much of the data, that my knowledge alllows me to, in to an array and doing the calculations in memory *should* speed
up quite a lot.
This is kind of a big ask but I have tried to explain what I am trying do and what I have done to get as best as I can.=IF(AND(A2=A3,B2=B3,I2=I3,J2=J2),"",TEXTJOIN("+",,CHOOSE({1,2},IF(COUNTIFS( E$2:E2,1,B$2:B2,B2),"YES",""),IF(COUNTIFS(E$2:E2,2,B$2:B2,B2),"NO",""),2)))
I am extremely grateful for any assistance.
Sub SortAndWriteLettersClmK() 'Turn off application settings Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim ws As Worksheet Dim lastRow As Long, i As Long, startRow As Long Dim matchCountOne As Long, matchCountTwo As Long Dim arrData As Variant, results() As String Set ws = ThisWorkbook.Worksheets("DATA SORT") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Read data into an array for faster processing arrData = ws.Range("A2:J" & lastRow).value ReDim results(1 To UBound(arrData)) 'Initialize startRow startRow = 1 For i = 1 To UBound(arrData) - 1 If arrData(i, 1) = arrData(i + 1, 1) And arrData(i, 2) = arrData(i + 1, 2) And _ arrData(i, 9) = arrData(i + 1, 9) And arrData(i, 10) = arrData(i + 1, 10) Then 'Matching row found, increment counts based on value in column E (position 5 in array) If arrData(i, 5) = 1 Then matchCountOne = matchCountOne + 1 ElseIf arrData(i, 5) = 2 Then matchCountTwo = matchCountTwo + 1 End If Else 'Non-matching or final match in a series - determine what to write in column K If matchCountOne > matchCountTwo Then FillResults results, startRow, i, "YES" ElseIf matchCountTwo > matchCountOne Then FillResults results, startRow, i, "NO" ElseIf matchCountOne = matchCountTwo And matchCountOne > 0 Then FillResults results, startRow, i, "MAYBE" End If 'Reset counters and set new start row matchCountOne = 0 matchCountTwo = 0 startRow = i + 1 End If Next i 'Write results to Column K ws.Range("K2:K" & lastRow).value = Application.Transpose(results) 'Turn on application settings Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub FillResults(arr() As String, start As Long, endRow As Long, value As String) 'Helper sub Dim i As Long For i = start To endRow arr(i) = value Next i End Sub


Reply With Quote


