So, I'm trying to figure out how to write an Excel macro to populate Column C with either 3 or a 4 depending on the amount of numbers contained in Column B.
I have searched up and down for the right wording to this, but I keep coming up short.
Basically, I need the macro to look at the number of digits in Column B. If there are 12 digits then the number is a UPC, and if there are 13 then the number is an EAN. I then need the macro to populate Column C with a 3 for UPCs and a 4 for EANs. This needs to be for the entire range of rows in the spreadsheet.
Does anyone have any ideas? Thanks a lot in advance!
You don't need to use a dirty old loop, try this (much faster if you have lots of rows):
Sub HTH()
With Sheet1.Range("B1", Cells(Rows.Count, "B").End(xlUp)).Offset(, 1)
.Formula = "=IF(LEN(TRIM(B1))=12,3,IF(LEN(TRIM(B1))=13,4,""""))"
.Value = .Value
End With
End Sub
Or use a user defined function, which has the advantage of changing when the data in column B is updated.
Better yet just use a formula, you don't really need VBA.
Alternative VBA Method (looping the fast way):
Sub HTH()
Dim vArray As Variant
Dim lCnt As Long
With Range("B1", Cells(Rows.Count, "B").End(xlUp))
vArray = .Value
For lCnt = 1 To UBound(vArray, 1)
Select Case Len(Trim(vArray(lCnt, 1)))
Case 12: vArray(lCnt, 1) = 3
Case 13: vArray(lCnt, 1) = 4
Case Else:
End Select
Next lCnt
.Offset(, 1).Value = vArray
End With
End Sub
You can get the length of a cell's value by using Len() like this Len(Range("A1")) for example.
Now you just need to loop through your column and look at each value. If you look for the last used cell and loop only through that range your loop will be faster.
Here is how I would do it:
sub TestUPC()
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Dim rRng As Range
Set rRng = Range("B1:B" & LastRow)
For Each cell In rRng.Cells
If Len(Trim(cell))=12 then
cell.Offset(0, 1).Value = 3
ElseIf Len(Trim(cell))=13 then
cell.Offset(0, 1).Value = 4
End If
Next
End Sub
An in cell equation could look like this:
=IF(LEN(B1)=12,3,IF(LEN(B1)=13,4," "))
As suggested in the comments you might want to test for spaces depending on your data:
=IF(LEN(TRIM(A1))=12,3,IF(LEN(TRIM(A1))=13,4," "))
Related
So I have some code using for loops currently doing this and it takes roughly 6 minutes to run...
I have many sheets showing the same columns with some different data.
One column comes in either a named form or a numerical form (Depending on how a user input it to a completely separate database).
Another database contains 2 columns: one being the numerical form of data while the other is named.
My database currently compares my "name" column if numerical with the numerical column in this other database and when it finds a match it changes my "name" cell to match the corresponding name cell in the other database.
Is there any faster way to do this than using for loops?
I have to replicate the code around 12 times for different sheets to do the same task.
As previously stated, overall to run across all 12 its taking around 6 minutes
Sub 6mincode()
Workbooks("1").Activate
N = Workbooks("1").Sheets("Data").Cells(Rows.Count, "B").End(xlUp).Row
N2 = Workbooks("2").Sheets("Data Sheet").Cells(Rows.Count, "B").End(xlUp).Row
For I = 2 To N
If (WorksheetFunction.IsNumber(Sheets("Data").Cells(I, "B").Value)) = True Then
For zz = 8 To N2
If StrComp(Sheets("Data").Cells(I, "B").Value, Workbooks("2").Sheets("Data Sheet").Cells(zz, "B").Value) = 0 Then
Workbooks("1").Sheets("Data").Cells(I, "B").Value = Workbooks("2").Sheets("Data Sheet").Cells(zz, "C").Value
End If
Next zz
End If
Next I
End Sub
You can save the second loop and use Application.Match instead, it will save you a lot of time.
See code below, explanations inside the code's comments:
Option Explicit
Sub Sixmincode()
Dim N As Long, N2 As Long, I As Long
Dim Rng As Range, MatchRow
With Workbooks("1").Sheets("Data")
N = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
With Workbooks("2").Sheets("Data Sheet")
N2 = .Cells(.Rows.Count, "B").End(xlUp).Row ' get last row with data in column B
' set the Range to Match with
Set Rng = .Range("B8:B" & N2)
End With
With Workbooks("1").Sheets("Data")
For I = 2 To N
If IsNumeric(.Cells(I, "B").Value) Then ' use IsNumeric
' use Application.Match, if Not IsError means there is a match found in the second workbook
If Not IsError(Application.Match(.Cells(I, "B").Value, Rng, 0)) Then
MatchRow = Application.Match(.Cells(I, "B").Value, Rng, 0)
.Cells(I, "B").Value = Workbooks("2").Sheets("Data Sheet").Cells(MatchRow, "C").Value
End If
End If
Next I
End With
End Sub
Just started a new job. I'm automating a month-end report and I'm new at VBA. Been googling most of my issues with success, but I've finally run into a wall. In essence I'm downloading some data from SAP and from there I need to build a report.
My question is: How to do a sumif function using loops in VBA?
Data pull:
Sheet1 contains a product code and purchase amounts (columns A & B) respectively. One product code can have several purchases (several rows with the same product code).
Steps so far:
I arranged the data sheet1 to be in ascending order.
Copied unique values for the product codes onto another sheet (sheet2). So Sheet2 has a list of all the products (in ascending order).
I want to get the sum of all purchases in sheet2 column B (per product code). I know how to do this using formulas, but I need to automate this as much as possible. (+ I'm genuinely interested in figuring this out)
This is what I did in VBA so far:
Sub Macro_test()
Dim tb As Worksheet
Dim tb2 As Worksheet
Dim x As Integer
Dim y As Integer
Dim lrow As Long
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
lrow = tb.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lrow
For y = 2 To lrow
If tb2.Cells(x, 1).Value = tb.Cells(y, 1).Value Then
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
End If
Next y
Next x
End Sub
If i'm not mistaken, for each product_code in sheet2 col A, I'm looping through all the product codes in sheet1 and getting back the LAST value it finds, instead of the sum of all values... I understand why it doesn't work, I just don't know how to fix it.
Any help would be much appreciated. Thanks!
This statement overwrites the value of tb2.Cells(x, 2).Value at each iteration:
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
Instead, I think you need to keep adding to it:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + tb.Cells(y, 2).Value
But I don't like the looks of your double-loop which uses only one lrow variable to represent the "last row" on the two different worksheets, that could be causing some issues.
Or, in your loop do something like this which I think will avoid the duplicate sum. Still, assumes the second worksheet doesn't initially have any value in
' Base our lRow on Sheet2, we don't care how many rows in Sheet1.
lrow = tb2.Cells(tb2.Rows.Count, 1).End(xlUp).Row
Dim cl as Range
Set cl = tb.Cells(2,1) 'Our initial cell value / ID
For x = 2 to lRow '## Look the rows on Sheet 2
'## Check if the cell on Sheet1 == cell on Sheet2
While cl.Value = tb2.Cells(x,1).Value
'## Add cl.Value t- the tb2 cell:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + cl.Offset(0,1).Value
Set cl = cl.Offset(1) '## Reassign to the next Row
Wend
Next
But it would be better to omit the double-loop and simply use VBA to do 1 of the following:
1. Insert The Formula:
(See Scott Holtzman's answer).
This approach is better for lots of reasons, not the least of which is that the WorksheetFunction is optimized already, so it should arguably perform better though on a small dataset the difference in runtime will be negligible. The other reason is that it's stupid to reinvent the wheel unless you have a very good justification for doing so, so in this case, why write your own version of code that accomplishes what the built-in SumIf already does and is specifically designed to do?
This approach is also ideal if the reference data may change, as the cell formulas will automatically recalculate based on the data in Sheet1.
2. Evaluate the formula & replace with values only:
If you prefer not to retain the formula, then a simple Value assignment can remove the formula but retain the results:
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
.Value = .Value 'This line gets rid of the formula but retains the values
End With
Use this approach if you will be removing Sheet1, as removing the referents will break the formula on Sheet2, or if you otherwise want the Sheet2 to be a "snapshot" instead of a dynamic summation.
If you really need this automated, take advantage of VBA to place the formula for you. It's very quick and easy using R1C1 notation.
Complete code (tested):
Dim tb As Worksheet
Dim tb2 As Worksheet
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
Dim lrow As Long
lrow = tb.Cells(tb.Rows.Count, 1).End(xlUp).Row
tb.Range("A2:A" & lrow).Copy tb2.Range("A2")
With tb2
.Range("A2").CurrentRegion.RemoveDuplicates 1
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
End With
End With
Note that with R1C1 notation the C and R are not referring to column or row letters . Rather they are the column and row offsets from the place where the formula is stored on the specific worksheet. In this case Sheet!C[-1] refers to the entire A column of sheet one, since the formula is entered into column B of sheet 2.
I wrote a neat little algorithm (if you can call it that) that does what you want them spits out grouped by totals into another sheet. Basically it loops through the first section to get unique names/labels and stores them into an array. Then it iterates through that array and adds up values if the current iteration matches what the current iteration of the nested loop position.
Private Sub that()
Dim this As Variant
Dim that(9, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("Sheet4").UsedRange
rowC = ThisWorkbook.Sheets("Sheet4").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("Sheet4").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue + this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("sheet5").Range(ThisWorkbook.Sheets("Sheet5").Cells(1, 1), ThisWorkbook.Sheets("Sheet5").Cells(rowC, colC)).Value2 = that
End Sub
Yay arrays
I'm trying to use the trim function without success. After searching for the solution on this forum and other sources online I have seen many different approaches.
Is there no simple way of trimming a cell in VBA?
What I want is something like this:
Sub trimloop()
Dim row As Integer
row = 1
Do While Cells(row, 1) <> ""
Cells(row, 2) = trim(Cells(row, 2))
row = row + 1
Loop
So that when there is a value in column A (1) the value in column B (2) should be trimmed of any extra spaces. I just cant get this to work for me.
Appreciate any help/tips!
Regards
Jim
So i made the code a bit accurate and mistakeproof and it worked.
So i can recommend you to double check, if you have correct row and column values, because you probably targeting wrong cells. (cause your code is working)
Sub trimloop()
Dim row As Integer
Dim currentSheet As Worksheet
Set currentSheet = sheets("Sheet1")
row = 2
Do While currentSheet.Cells(row, 1) <> ""
currentSheet.Cells(row, 2).Value = Trim(currentSheet.Cells(row, 2).Value)
row = row + 1
Loop
End Sub
Use Application.WorksheetFunction.Trim(string)
Sub trimloop()
Dim row As Integer
row = 1
With ThisWorkbook.ActiveSheet
Do While .Cells(row, 1) <> ""
.Cells(row, 2) = Application.WorksheetFunction.Trim(.Cells(row, 2))
row = row + 1
Loop
End With
End Sub
this is the optimized version of your code, in case of big data sheets:
Option Explicit
Sub trimloop()
Dim row As Long, max As Long
Dim Data() As Variant
With ThisWorkbook.Sheets(1)
max = .Cells(1, 1).End(xlDown).row 'this does the same as your code, on first empty cell it stops
'the following finds the last un-empty cell of column(1):
'max= .cells(.rows.count,1).end(xlup).row
'copies values from sheet to memory (is faster for working with later)
Data = .Range(.Cells(1, 1), .Cells(max, 2)).Value2
'loop :
For row = 2 To max + 1
'work with memory instead of sheet
Data(row, 2) = Trim(Data(row, 2))
'for complete delete of all spaces use : = replace( StringName," ", "")
Next row
'write back to sheet
.Range(.Cells(1, 1), .Cells(max, 2)).Value2 = Data
End With
erase Data 'free memory
End Sub
Don't know if this overly simplified... but thought I would simply throw it out there this worked for me. The only predecessor step is you assign a "named range" to your workbook/worksheet/dataset ... name a data set and then iterate over the data set with this code
Sub forEachLoop()
For Each cell In Range("yourNamedRange")
cell.Value = Trim(cell.Value)
Next cell
End Sub
Is there a way to check if all cells in a column are less than 1? If there were only a few cells, with the number of cells known up front, I would use the code below.
However, from case to case the number of cells in column A will vary. I need to know if any of the cells in column A is less than 1.
If there is one (or more) cell containing a value less than 1, I need a cell (A1 for example) to show NOT OK. If only ALL the cells' values are greater than 1, I need the cell (A1 for example) to show OK.
If all cells in column A have values greater than 1, I want to continue and check column B for the same thing. Otherwise I want to save and close the workbook and continue with next open workbook...also with vba code.
Any suggestions on how to write this in VBA? Maybe there is way other than If(AND...)?
Sub IfAnd()
IF(AND(A5>1,A4>1,A3>1,A2>1),"OK", "NOT OK")
End Sub
This code will solve all your columns and insert the data in THE FIRST ROW OF EACH COLUMN
Sub Problems()
Dim CurCol, LastRow, LastCol as Long
LastCol = Cells(2, Columns.Count).End(xlToLeft).Column
For CurCol = 1 to LastCol
LastRow = Cells(Rows.Count, CurCol).End(xlUp).Row
If WorksheetFunction.Min(Range(Cells(2, CurCol), Cells(LastRow, CurCol))) < 1 Then
Cells(1, CurCol).Value = "NOT OK"
Else
Cells(1, CurCol).Value = "OK"
End If
Next CurCol
End Sub
Here is a way of doing it without any worksheet functions.
Sub test()
Dim ws As Worksheet
Dim ce As Range
Dim sr, lr, lc As Integer
'worksheet you are working with
Set ws = ThisWorkbook.Sheets(1)
'column you are searching
Set ce = ws.Cells(ws.Rows.Count, 1)
'start row set to 2 so row 1 will contain output
Let sr = 2
'search only the last row
Let lr = ce.End(xlUp).Row
Let lc = ws.Cells(sr, ws.Columns.Count).End(xlToLeft).Column
For c = 1 To lc
For r = sr To lr
If ws.Cells(r, c).Value < 1 Then
ws.Cells(1, c).Value = "NOT OK"
GoTo NotOK
End If
Next r
ws.Cells(1, c).Value = "OK"
NotOK:
Set ce = ws.Cells(ws.Rows.Count, c+1)
Let lr = ce.End(xlUp).Row
Next c
End Sub
This should be faster and more efficient for large data sets. Especially if it is sorted smallest to largest.
Here you are:
=IF(MAX(A:A)<1)
If VBA is not required, here is a worksheet formula that should do the job, and will also ignore blanks and non-numeric entries:
This formula must be array-entered:
=IF(ISNUMBER(MATCH(TRUE,IF(ISNUMBER($A:$A),$A:$A)<1,0)),"NOT OK","OK")
If this formula must be located in A1, change the range references from $A:$A to $A$2:$A$1000 where 1000 represents the highest conceivable row number for the data.
To array-enter a formula, after entering
the formula into the cell or formula bar, hold down
< ctrl-shift > while hitting < enter >. If you did this
correctly, Excel will place braces {...} around the formula.
Need a much Optimized code.Well I Got a Project and I have Succefully made it work with the vba (Mostly helped by the stackoverflow programmers Thanks for that)
But Today I got a Feedback. Its deleting 2 more unique entries in the record But I dont know why its deleting Them.
The Algorithm I have applied
I have Used the COUNTIF function Which I found on google
="countif(A$1:A2,A3)=0" A3 is the active cell, Checks A2,A1 for dupes
It Throws False if there is a duplicate in The A column and True If it is a unique.What I have understood about Countif is that
It checks all the above columns values from that cell I mean let us take A4. SO it checks A2,A1,A3 for the duplicate. Similarly A10 checks for A1 to A9 and throws either TRue or False.Well It was working But I dont know what went wrong The code is not working for some entries.Its even showing False for the Unique entries sometimes.
And its taking more time to applye these formula as I have more amount of data. Im trying to make it cleaner and more Optimizing Way.People told me its not a c or some other Language to make it optimize but Im need of code that makes my code more optimized
I need code for these condtions can anyone help me as my countif failed.Im little helpless in doing so.
1)I have a column and I should check for duplicates in that column and delete that row if it is a duplicate
2) I have 35000 Old entries in the column and I have new entries 2000 everyweek these are appended. I need to check these 2000 entries from the total 37000 ( as we appened we get 35000+2000) and these delete operation need to be performed only on the newly appended 2000 entries but it should check the duplicates for entire column
Let me explain you clearly I have 2000 entries newly added,so Only these entries are to be checked for the duplicates from the 35000 entries and also from itself (2000 entries) and delete it if it is a duplicate and no duplicating operation should be performed on the 35000 entries old data.
I have found some codes but they are deleting even the duplicates of the 35000 entries. I have set the range but even though its not working.
Can anyone help me with the best code that takes less time?please thank you
Updating my question with the sample code I have
A B F G H I Y
PTY 39868.5 4 2 540 3 PTY39868.5425403
GTY 34446.1234 2 1 230 1 GTY34446.1234212301
PTY 3945.678 2 2 PTY3945.67822
GTY 34446.1234 2 1 230 1 GTY34446.1234212301
let us say these are old 35000 entries
Explaination to the above example.
The above are the 35000 entries. I have to check A,B,F,G,H,I columns for the dupes, if they are same I have to delete the row, I should not bother about the other columns c,d etc. so what I did is I have used one unused column Y and concatenated these 6 columns values into 1 at Y column using these
= A2 & B2 & F2 & G2 & H2 &I2 with the respective columns
Now checking the Y column for dupes and delete the entire row. as 2003 supports only for one column as far to my knowledge.
Notice that even the 35000 entries may have duplicates in it but I should not delete them. Example you can see the 2 and last row in my example code are dupes but I should not delete
as it is the old data.
A B F G H I Y
PTY 39868.5 4 2 540 3 PTY39868.5425403 'old
GTY 34446.1234 2 1 230 1 GTY34446.1234212301 'old
PTY 3945.678 2 2 PTY3945.67822 'old
GTY 34446.1234 2 1 230 1 GTY34446.1234212301 'old
PTY 3945.678 1 1 230 2 PTY3945.678112302 'new
PTY 39868.5 4 2 540 3 PTY39868.5425403 'new
PTY 3945.678 1 1 230 2 PTY3945.678112302 'new
Now note that New entry PTY (from last 2nd) is a duplicate of the original record(PTY at first) So I hava to delete it.And the last new entry is a duplicate of the new entry itself so I should delete it even that . SO in the above code I have to delete only the last 2 rows which are dupes of original record and also from it . But should not delete the GTY which is the dupe but which is in orginal record.
I think I gave a clear view now. Is concatenating them into one cell . Is it better way to approach? as conactenatin for 40000 entries taking just 2 seconds i think that doesnt matter but any more algorithms to these is much aprreciated
I heard counif treats 45.00 and 45.00000 as different is that right may be that was the problem with it? since I have decimal points in my data. I think I should do
= I2 & H2 & G2 & F2 & A2 & B2
which is better to concatenate? is this or the other i posted before?
BIG UPDATE:
It think the original questions threw me off - there may be a problem with the logic in the question. The following assumes you want to delete the cell, not entire row, for the duplicate entries.
If the 35000 old records do not include duplicates, then all you need to do is remove all duplicates from the entire column - so long as you start from row 1, you run no risk of deleting any of the 'old' rows since no duplicates exist in them.
Here is one way:
Sub UniqueList()
Application.ScreenUpdating = False
Dim vArray As Variant
Dim i As Long, j As Long, lastrow As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
lastrow = Range("A" & Rows.Count).End(xlUp).Row
vArray = Range("A1:A" & lastrow).Value
On Error Resume Next
For i = 1 To UBound(vArray, 1)
For j = 1 To UBound(vArray, 2)
If Len(vArray(i, j)) <> 0 Then
dictionary(vArray(i, j)) = 1
End If
Next
Next
Columns("A:A").ClearContents
Range("A1").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
End Sub
If for some odd reason the 35000 old records DO include dupes and you only want to allow these 35000 records to do so, then you can use 2 dictionaries, but this would be an unusual case since you'd be treating the old records differently than new...
Sub RemoveNewDupes()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim varray As Variant
Dim oldDict As Object, newDict As Object
Set oldDict = CreateObject("scripting.dictionary")
Set newDict = CreateObject("scripting.dictionary")
On Error Resume Next
lastRow = Range("A" & Rows.Count).End(xlUp).Row
'Add old entries to dictionary
varray = Range("A1:A35000").Value
For i = 1 To UBound(varray, 1)
oldDict.Add varray(i, 1), 1
Next
'Check for dupes
varray = Range("A35001:A" & lastRow).Value
For i = 1 To UBound(varray, 1)
If oldDict.exists(varray(i, 1)) = False Then
newDict.Add varray(i, 1), 1
End If
Next
'Delete and slap back on the unique list
Range("A35001", "A" & Rows.Count).ClearContents
Range("A35001").Resize(newDict.Count).Value = _
Application.Transpose(newDict.keys)
Application.ScreenUpdating = True
End Sub
Thanks to Reafidy for the advice and getting me to relook at this.
This is also a response to some of the comments and solutions made by other members so sorry if it does not straight away answer your question.
Firstly I believe that using excel in a database scenario that raw data and presentation data should be separated. This usually means a single worksheet with raw data and multiple other worksheets with presentation data. Then delete the raw data when necessary or archive.
When speed testing it is very difficult to get a level playing field in excel as there are many things that affect the results. Computer specs, available RAM etc.. Code must first be compiled before running any of the procedures. The test data is also important, when considering duplicates - how many duplicates vs how many rows. This sub loads some test data, altering the amount of rows vs the range of random numbers (duplicates) will give very different results for your code. I don't know what your data looks like so we are kind of working blind and your results may be very different.
'// This is still not very good test data, but should suffice for this situation.
Sub TestFill()
'// 300000 rows
For i = 1 To 300000
'// This populates a random number between 1 & 10000 - adjust to suit
Cells(i, "A").value = Int((100000 + 1) * Rnd + 1)
Next
End Sub
If we are talking about advanced filter vs an array & dictonary method then advanced filter will be quicker with a lower amount of rows but once you get above a certain amount of rows then the array method will be quicker. Then see what happens when you change the amount of duplicates.... :)
As a guideline or as a general rule using excels built in functions will be faster and I recommend always develop attempting to use these inbuilt functions, however there are often exceptions, like above when removing duplicates. :)
Deleting rows can be slow when looping if used incorrectly. If looping is used then it is important to keep synchronisation between code and the workbook out of the loop. This usually means read data to an array, loop through the data, then load the data from the array back to the presentation worksheet essentially deleting the unwanted data.
Sub RemoveDuplicatesA()
'// Copy raw data to presentation sheet
Range("A1", Cells(Rows.Count, "A").End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=Sheet2.Range("B1"), Unique:=True
End Sub
This will be the fastest method:
Sub RemoveDuplicatesB()
Dim vData As Variant, vArray As Variant
Dim lCnt As Long, lRow As Long
vData = ActiveSheet.UsedRange.Columns(1).value
ReDim vArray(0 To UBound(vData, 1), 0)
lCnt = 0
With CreateObject("Scripting.Dictionary")
For lRow = 1 To UBound(vData, 1)
If Not .Exists(vData(lRow, 1)) Then
vArray(lCnt, 0) = vData(lRow, 1): lCnt = lCnt + 1
.Add vData(lRow, 1), Nothing
End If
Next lRow
End With
'// Copy raw data to presentation sheet
Sheet2.Range("B1").Resize(lCnt).value = vArray
End Sub
Application transpose has a limitation of 65536 rows but as you are using 2003 you should be fine using it, therefore you can simplify the above code with:
Sub RemoveDuplicatesC()
Dim vData As Variant
Dim lRow As Long
vData = ActiveSheet.UsedRange.Columns(1).value
With CreateObject("Scripting.Dictionary")
For lRow = 1 To UBound(vData, 1)
If Not .exists(vData(lRow, 1)) Then
.Add vData(lRow, 1), Nothing
End If
Next lRow
'// Copy raw data to presentation sheet or replace raw data
Sheet2.Columns(2).ClearContents
Sheet2.Columns(2).Resize(.Count).value = Application.Transpose(.keys)
End With
End Sub
EDIT
Okay so #Issun has mentioned you want the entire row deleted. My suggestion was to improve your spreadsheet layout by having a raw data and presentation sheet which means you dont need to delete anything hence it would have been the fastest method. If you dont want to do that and would like to edit the raw data directly then try this:
Sub RemoveDuplicatesD()
Dim vData As Variant, vArray As Variant
Dim lRow As Long
vData = ActiveSheet.UsedRange.Columns(1).value
ReDim vArray(1 To UBound(vData, 1), 0)
With CreateObject("Scripting.Dictionary")
For lRow = 1 To UBound(vData, 1)
If Not .exists(vData(lRow, 1)) Then
varray(lRow, 0) = "x"
.Add vData(lRow, 1), Nothing
End If
Next lRow
End With
Application.ScreenUpdating = False
'// Modify the raw data
With ActiveSheet
.Columns(2).Insert
.Range("B1").Resize(lRow).value = vArray
.Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns(2).Delete
End With
Application.ScreenUpdating = True
End Sub
Before starting again from scratch your whole code, here are a few things you can try:
Optimize your VBA
There are several tips on the web about optimizing vba. In particular, you can do:
'turn off some Excel functionality so your code runs faster
'these two are especially very efficient
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'use these if you really need to
Application.DisplayStatusBar = False
Application.EnableEvents = False
'code goes here
'at the end, restore the default behavior
'calculate the formulas
Application.Calculate
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
See here for more information
Optimize your algorithm
Especially when your inserting your COUNTIF formula, you can try to fill in instead of inserting the formula in each row.
On the deleting row part, you should try the solution I gave you in your previous thread: Delete duplicate entries in a column in excel 2003 vba to filter first on the True values and then to delete the visible cells. It is probably the fastest way.
[EDIT] Seems like Doc Brown's answer would be probably the best way to handle this (hey, this is a dictionary solution that wasn't written by Issun :)). Anyway, the VBA optimization tips are still relevant because this is quite a slow language.
OK, here's the advancedfilter method. Don't know if it is faster than the dictionary method. It would be interesting to know though, so let me know after you try it. I also included the delete portion so you would have to stop that portion if you want to do a true comparison. Also, you can make this a function instead of a sub and put in your variables, however you want to change it.
Sub DeleteRepeats()
Dim d1 As Double
Dim r1 As Range, rKeepers As Range
Dim wks As Worksheet
d1 = Timer
Set wks = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = False
'Make sure all rows are visible
On Error Resume Next
wks.ShowAllData
wks.UsedRange.Rows.Hidden = False
wks.UsedRange.Columns.Hidden = False
On Error GoTo 0
'Get concerned range
Set r1 = wks.Range("A1:A35000")
'Filter
r1.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
'Get range of cells not to be deleted
Set rKeepers = r1.SpecialCells(xlCellTypeVisible)
On Error Resume Next
wks.ShowAllData
On Error GoTo 0
rKeepers.EntireRow.Hidden = True
'Delete all undesirables
r1.SpecialCells(xlCellTypeVisible).EntireRow.Delete
'show all rows
On Error Resume Next
wks.UsedRange.Rows.Hidden = False
On Error GoTo 0
Application.EnableEvents = False
Application.ScreenUpdating = False
Debug.Print Timer() - d1
End Sub
OK, here's a take on Doc's and Issun's use of Dictionaries. Before I wasn't convinced but after looking at it and testing it and comparing to advanced filter, I am convinced, dictionaries are better for this application. I don't know why Excel isn't faster on this point since they should be using faster algorithms, it's not the hiding, unhiding of the rows since that happens very quickly. So if anyone knows, let me know. This procedure takes just over 1 second on my slow computer:
Sub FindDupesAndDelete()
Dim d1 As Double
Dim dict As Object
Dim sh As Worksheet
Dim v1 As Variant
' Dim s1() As String
Dim rDelete As Range
Dim bUnion As Boolean
d1 = Timer()
bUnion = False
Set dict = CreateObject("Scripting.Dictionary")
Set sh = ActiveSheet
v1 = Application.Transpose(sh.Range("A1", "A" _
& sh.Cells.SpecialCells(xlCellTypeLastCell).row))
' ReDim s1(1 To UBound(v1))
Dim row As Long, value As String ', newEntry As Boolean
For row = 1 To sh.Cells.SpecialCells(xlCellTypeLastCell).row
value = v1(row)
If dict.Exists(value) Then
' newEntry = False
If bUnion Then
Set rDelete = Union(rDelete, sh.Range("A" & row))
Else
Set rDelete = sh.Range("A" & row)
bUnion = True
End If
Else
' newEntry = True
dict.Add value, 1
End If
' s1(row) = newEntry
Next
rDelete.EntireRow.Delete
' sh.Range("B1", "B" & UBound(v1)) = Application.Transpose(s1)
Debug.Print Timer() - d1
End Sub
Okay so now we have some more info here is a solution. It should execute almost instantly.
The code works by filling column y with your concatenate formula. It then adds all of column y to a dictionary and using the dictionary marks each row as a duplicate in column z. It then removes all the duplicates found after row 35000. Then finally it clears both column y and column z to remove the redundant data.
Sub RemoveDuplicates()
Dim vData As Variant, vArray As Variant
Dim lRow As Long
'// Get used range of column A (excluding header) and offset to get column y
With ActiveSheet.Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 24)
'// Adds the concatenate formula to the sheet column (y)
.FormulaR1C1 = "=RC[-24]&RC[-23]&RC[-19]&RC[-18]&RC[-17]&RC[-16]"
'// Adds the formula results to an array
vData = .Resize(, 1).value
End With
'// Re dimension the array to the correct size
ReDim vArray(1 To UBound(vData, 1), 0)
'// Create a dictionary object using late binding
With CreateObject("Scripting.Dictionary")
'// Loop through each row in the array
For lRow = 1 To UBound(vData, 1)
'// Check if value exists in the array
If Not .exists(vData(lRow, 1)) Then
'// Value does not exist mark as non duplicate.
vArray(lRow, 0) = "x"
'// Add value to dictionary
.Add vData(lRow, 1), Nothing
End If
Next lRow
End With
'// Turn off screen updating to speed up code and prevent screen flicker
Application.ScreenUpdating = False
With ActiveSheet
'// Populate column z with the array
.Range("Z2").Resize(UBound(vArray, 1)) = vArray
'// Use error handling as speciallcells throws an error when none exist.
On Error Resume Next
'// Delete all blank cells in column z
.Range("Y35001", .Cells(Rows.Count, "Y").End(xlUp)).Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'// Remove error handling
On Error GoTo 0
'// Clear columns y and z
.Columns(25).Resize(, 2).ClearContents
End With
'// Turn screen updating back on.
Application.ScreenUpdating = True
End Sub
NOTE: you can change all references "activesheet" to your sheet codename if you want.
NOTE2: it assumes you have headers and has left row 1 alone.
I have used your columns and test data as best I can. Here is the test fill I used:
Sub TestFill()
For i = 1 To 37000
With Range("A" & i)
.value = Choose(Int(2 * Rnd + 1), "PTY", "GTY")
.Offset(, 1).value = Round((40000 * (Rnd + 1)), Choose(Int(4 * Rnd + 1), 1, 2, 3, 4))
.Offset(, 5).value = Int(4 * Rnd + 1)
.Offset(, 6).value = Int(2 * Rnd + 1)
.Offset(, 7).value = Choose(Int(2 * Rnd + 1), "230", "540")
.Offset(, 8).value = Int(3 * Rnd + 1)
End With
Next i
End Sub
Lets say you have your entries in column A, and you want the result of your formula in column B (but much faster). This VBA macro should do the trick:
Option Explicit
Sub FindDupes()
Dim dict As Object
Dim sh As Worksheet
Set dict = CreateObject("Scripting.Dictionary")
Set sh = ActiveSheet
Dim row As Long, value As String
For row = 1 To sh.Cells.SpecialCells(xlCellTypeLastCell).row
value = sh.Range("A" & row).Text
If dict.Exists(value) Then
sh.Range("B" & row) = "False"
Else
sh.Range("B" & row) = "True"
dict.Add value, 1
End If
Next
End Sub
(Using a dictionary gives here almost linear running time, which should be a matter of seconds for 35.0000 rows, where your original formula had quadratic running time complexity).
Edit: due to your comment: you will have to fill the dictionary first by reading each entry at least once, that is something you cannot avoid easily. What you can avoid is to fill the rows of column B again when they are already filled:
Option Explicit
Sub FindDupes()
Dim dict As Object
Dim sh As Worksheet
Set dict = CreateObject("Scripting.Dictionary")
Set sh = ActiveSheet
Dim row As Long, value As String, newEntry As Boolean
For row = 1 To sh.Cells.SpecialCells(xlCellTypeLastCell).row
value = sh.Range("A" & row).Text
If dict.Exists(value) Then
newEntry = False
Else
newEntry = True
dict.Add value, 1
End If
If Trim(sh.Range("B" & row)) = "" Then sh.Range("B" & row) = newEntry
Next
End Sub
But I suspect this won't be much faster than my first solution.
Now that you have updated that you want the entire rows deleted and that the first 35000 rows are allowed to have dupes, here is a function that will do that for you. I think I came up with a clever method and it's blazing fast, too:
Sub RemoveNewDupes()
Application.ScreenUpdating = False
Dim lastRow As Long
Dim varray As Variant
Dim oldDict As Object, newDict As Object
Set oldDict = CreateObject("scripting.dictionary")
Set newDict = CreateObject("scripting.dictionary")
On Error Resume Next
lastRow = Range("A" & Rows.Count).End(xlUp).Row
'Add old entries to dictionary
varray = Range("A1:A35000").Value
For i = 1 To UBound(varray, 1)
oldDict.Add varray(i, 1), 1
Next
'Check for dupes
varray = Range("A35001:A" & lastRow).Value
For i = 35000 + UBound(varray, 1) To 35001 Step -1
If oldDict.exists(varray(i - 35000, 1)) = True Or _
newDict.exists(varray(i - 35000, 1)) = True Then
Range("A" & i).EntireRow.Delete
Else
newDict.Add varray(i - 35000, 1), 1
End If
Next
Application.ScreenUpdating = True
'A status message at the end for finishing touch
MsgBox UBound(varray, 1) - newDict.Count & _
" duplicate row(s) found and deleted."
End Sub
How it works:
First I store the 35000 cells into a dictionary file. Then I take a variant array of every cell 35001 onward and loop through them backwards to see if it's in the 35k dictionary or not, or that we haven't come across the value yet in the loop. If it finds that it's a dupe, it deletes the row.
The cool (if I may say) way that it does the row deletion is that when you create the varray, for say A35001 - A37000, it stores them as (1, 1) (2, 1) (...). So if you set "i" to the Ubound of the array + 35000 and step back to 35001, you will loop through all the additions backwardsfrom A37000 to A35001. Then when you want to delete the row, "i" is perfectly set to the row number the value was found in, so you can delete it. And since it goes backwards, it does not screw up the loop!