excel vba - VBA for duplicate rows -
i have sheet of columns. want compare data in multiple columns, , return flag in column indicate rows duplicates. found little code online meant checking 1 column of data, , have far been unsuccessful in being able tweek multiple columns. final code need @ specific columns define later moment sheet follows: staffnumber calltype
1 a
2 b
1 a
4 d
5 e
6 f
7 g
8 h
1 a
2 c
1 z
6 p
the col labelled staff number. col b labelled calltype. in col c want flag entered against row.
my code follows:
sub duplicateissue()
dim last_staffnumber long dim last_calltype long dim match_staffnumber long dim match_calltype long dim staffnumber long dim calltype long last_staffnumber = range("a65000").end(xlup).row last_calltype = range("b65000").end(xlup).row staffnumber = 1 last_staffnumber calltype = 1 last_calltype 'checking if staff number cell having item, skipping if blank. if cells(staffnumber, 1) <> " " 'getting match index number value of cell match_staffnumber = worksheetfunction.match(cells(staffnumber, 1), range("a1:a" & last_staffnumber), 0) if cells(calltype, 2) <> " " match_calltype = worksheetfunction.match(cells(calltype, 2), range("b1:b" & last_calltype), 0) 'if match index not equals current row number, duplicate value if staffnumber <> match_staffnumber , calltype <> match_calltype 'printing label in column c cells(staffnumber, 3) = "duplicate" end if end if end if next next
end sub
my problem when col 1 duplicate macro enter "duplicate" col c, , not checking if value of col b same. appreciated.
try code:
.
option explicit public sub showduplicaterows() const sheet_name string = "sheet1" const last_col long = 3 ' <<<<<<<<<<<<<<<<<< update last column const first_row long = 2 const first_col long = 1 const dupe string = "duplicate" const case_sensitive byte = 1 'matches upper & lower dim includedcolumns object set includedcolumns = createobject("scripting.dictionary") includedcolumns .add 1, "" ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 1 dupe criteria .add 3, "" ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 3 dupe criteria end dim searchrng range dim memarr variant dim long dim j long dim unique string dim totalrows long dim totalcols long dim totalurcols long dim valdict object set valdict = createobject("scripting.dictionary") if case_sensitive = 1 valdict.comparemode = vbbinarycompare else valdict.comparemode = vbtextcompare end if thisworkbook.sheets(sheet_name) totalrows = .usedrange.rows.count 'get last used row on sheet totalurcols = .usedrange.columns.count 'get last used col on sheet set searchrng = .range( _ .cells(first_row, first_col), _ .cells(totalrows, last_col) _ ) if last_col < totalurcols .range( _ .cells(first_row, last_col + 1), _ .cells(first_row, totalurcols) _ ).entirecolumn.delete 'delete columns end if end memarr = searchrng.resize(totalrows, last_col + 1) 'entire range data mem = 1 totalrows 'each row, without header j = 1 last_col 'each col if includedcolumns.exists(j) unique = unique & searchrng(i, j) 'concatenate values on same row end if next if valdict.exists(unique) 'check if entire row exists memarr(i, last_col + 1) = dupe 'if does, flag in last col else valdict.add key:=unique, item:=i 'else add dictionary end if unique = vbnullstring next searchrng.resize(totalrows, last_col + 1) = memarr 'entire memory sheet end sub
.
result:
Comments
Post a Comment