Solved: help

[chillijo]

Hello all,
Looking to find a way to alphabetize, count and delete duplicates, in columns of selected cells, then copy data from those selected cells another collumn of selected cells, while keeping a running numerical counting function in the copied columns. I attached pic to help,
thanks in advance

Joe B

[mdmackillop]

Welcolme to vbax
A sample excel workbook would be better. You can add comments etc. there to show excactly what you require.

[Bob Phillips]

Public Sub ProcessData()
Dim Lastrow As Long
Dim Nextrow As Long
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False

With ActiveSheet

For j = 2 To 8 Step 3

Lastrow = .Cells(.Rows.Count, j).End(xlUp).Row
For i = Lastrow To 5 Step -1

If .Cells(i, j).Value2 <> .Cells(i + 1, j).Value2 Then

.Cells(i, j + 1).Value2 = 1
Else

.Cells(i, j + 1).Value2 = .Cells(i, j + 1).Value2 + .Cells(i + 1, j + 1).Value2 + 1
.Cells(i + 1, j).Resize(, 2).Delete shift:=xlUp
End If
Next i

Lastrow = .Cells(.Rows.Count, j).End(xlUp).Row
For i = 5 To Lastrow

Nextrow = 0
On Error Resume Next
Nextrow = Application.Match(.Cells(i, j).Value2, .Columns("K"), 0)
On Error GoTo 0
If Nextrow = 0 Then

Nextrow = .Cells(.Rows.Count, "K").End(xlUp).Row + 1
.Cells(Nextrow, "K").Value2 = .Cells(i, j).Value2
.Cells(Nextrow, "L").Value2 = .Cells(i, j + 1).Value2
Else

.Cells(Nextrow, "L").Value2 = .Cells(Nextrow, "L").Value2 + .Cells(i, j + 1).Value2
End If
Next i
Next j
End With

Application.ScreenUpdating = True
End Sub

[chillijo]

Thanks Xld,
I Tried the script it worked, but not exactly as what i was trying to do, attached document to see , Thank you.
Let me try to explain again, as you can see on the picture I have multiple sets of teams, each teams set of cells
are divided a set of 3 independent months set of cells and a total set of cells. On the worksheet i'm trying to
alphabetize, count and delete duplicates, in each teams independent set of MONTH cells, then copy data from those
independent month cells to another of selected cells the TOTAL set of cells, while keeping a running numerical
counting function in the copied columns the total . All teams set of cell data must work independent of each other.
An exanple So if you look at it by color all blue data must be alphabetized, counted and delete duplicates, in each
teams independent set of month cells, then copy data from those indepentent month cells to the total column set of
blue cells, and so on down the worksheet by team .The colors are not used, I used them to help with the description. I've attached a worksheet with examples.
Again thanks in advance all.
Joe B

[Bob Phillips]

Jeez, that was hard



Public Sub ProcessData()
Dim vecHead As Variant
Dim Lastrow As Long
Dim Nextrow As Long
Dim Startrow As Long
Dim Endrow As Long
Dim Findrow As Long
Dim cell As Range
Dim firstAddress As String
Dim i As Long
Dim j As Long
Dim k As Long

Application.ScreenUpdating = False

With ActiveSheet

Lastrow = 70
Startrow = 5
For i = 1 To 6

On Error Resume Next
Set cell = .Columns("B:C").Find(What:="TEAM " & i + 1)
On Error GoTo 0

If cell Is Nothing Then

Endrow = Lastrow
Else

Endrow = cell.Row
End If

Nextrow = Startrow - 1
For j = 2 To 8 Step 3
For k = Endrow - 1 To Startrow Step -1

If .Cells(k, j).Value2 <> "" Then

If .Cells(k, j).Value2 <> .Cells(k + 1, j).Value2 Then

.Cells(k, j + 1).Value2 = 1
Else

.Cells(k, j + 1).Value2 = .Cells(k, j + 1).Value2 + .Cells(k + 1, j + 1).Value2 + 1
.Cells(k + 1, j).Resize(, 2).ClearContents
End If
End If
Next k

.Cells(Startrow, j).Resize(Endrow - Startrow, 2).Sort key1:=.Cells(i, j), order1:=xlAscending, Header:=xlNo

For k = Startrow To Endrow - 1

If .Cells(k, j).Value2 <> "" Then

Findrow = 0
On Error Resume Next
Findrow = Application.Match(.Cells(k, j).Value2, .Cells(Startrow, "K").Resize(Endrow - Startrow), 0)
On Error GoTo 0
If Findrow = 0 Then

Nextrow = Nextrow + 1
.Cells(Nextrow, "K").Value2 = .Cells(k, j).Value2
.Cells(Nextrow, "L").Value2 = .Cells(k, j + 1).Value2
Else

.Cells(Findrow + Startrow - 1, "L").Value2 = .Cells(Findrow + Startrow - 1, "L").Value2 + .Cells(k, j + 1).Value2
End If
End If
Next k
Next j

Startrow = Endrow + 1
Next i
End With

Application.ScreenUpdating = True
End Sub

[chillijo]

Thanks XLD