CopyPasteSortCountMacro

[MCheru]

Here is my code.

Columns("I:J").Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
Range("A1").Select
Application.CutCopyMode = False
Range("A1:B100").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

And this is what it does now.

Copy Column I:J
Open a new worksheet
Paste Column I:J into Column A:B of new worksheet.
Sort by/Column A/Ascending


I want to add to the code I have above so that it takes these additional
steps below.

Put a “1†in every cell in Column C if Column A:B have contents inside it.
(What is in Column A is associated with Column B).

Review every row in Column A:B from A1:B1 to A100:B100. When the same
contents appear two, three, or more times in any row in Column A:B, I want
that row to be deleted and the total/tally for the 1st time those contents
appeared in a row in Column A:B to be increased by “1†in Column C. In other
words each time an exact duplicate is found in A:B that row gets deleted and
the total/tally being kept in Column C for the first time those contents
appeared gets increased by “1â€

The contents are typically 10 characters long and a mixture of numbers and
letters which are sometimes connected by dashes (i.e) CF-88VBXWQ. There is
no pattern to the letters, numbers, or dashes.

Is this possible?

 

[Joel]

Sub CopySheet()
Set OldSht = ActiveSheet
Sheets.Add
Set NewSht = ActiveSheet

OldSht.Columns("I:J").Copy _
Destination:=NewSht.Columns("A")
Application.CutCopyMode = False
With NewSht
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
Set SortRange = .Rows("1:" & Lastrow)
SortRange.Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlYes
RowCount = 1
Do While .Range("A" & RowCount) <> ""
If .Range("C" & RowCount) = "" Then
.Range("C" & RowCount) = 1
End If
If .Range("A" & RowCount) = .Range("A" & (RowCount + 1)) And _
.Range("B" & RowCount) = .Range("B" & (RowCount + 1)) Then

.Range("C" & RowCount) = .Range("C" & RowCount) + 1
Rows(RowCount + 1).Delete
Else
RowCount = RowCount + 1
End If
Loop
End With
End Sub

 

[MCheru]

Thank you. This is great.

Sub CopySheet()
Set OldSht = ActiveSheet
Sheets.Add
Set NewSht = ActiveSheet

OldSht.Columns("I:J").Copy _
Destination:=NewSht.Columns("A")
Application.CutCopyMode = False
With NewSht
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
Set SortRange = .Rows("1:" & Lastrow)
SortRange.Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlYes
RowCount = 1
Do While .Range("A" & RowCount) <> ""
If .Range("C" & RowCount) = "" Then
.Range("C" & RowCount) = 1
End If
If .Range("A" & RowCount) = .Range("A" & (RowCount + 1)) And _
.Range("B" & RowCount) = .Range("B" & (RowCount + 1)) Then

.Range("C" & RowCount) = .Range("C" & RowCount) + 1
Rows(RowCount + 1).Delete
Else
RowCount = RowCount + 1
End If
Loop
End With
End Sub

 

[Joel]

For the code to weork properly you need to sort on columns A and B. Try this
change

from
SortRange.Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlYes

to
SortRange.Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Key2:=.Range("B1"), _
Order2:=xlAscending, _
Header:=xlYes