View Full Version : Solved: help
chillijo
10-23-2010, 02:28 PM
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
10-24-2010, 02:55 AM
Welcolme to vbax
A sample excel workbook would be better. You can add comments etc. there to show excactly what you require.
Bob Phillips
10-24-2010, 06:00 AM
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
10-25-2010, 09:53 AM
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
10-25-2010, 12:05 PM
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
10-28-2010, 07:34 AM
Thanks XLD
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.