PDA

View Full Version : [SOLVED] similar cells - grouping



DavidWaldo
02-14-2017, 01:52 PM
Hello,
Last time I asked how to sort items via VBA - wich was a great help (http://www.vbaexpress.com/forum/showthread.php?58561-New-work-assignment-Sort-data), now i hit another problem. I have a list of data (workbook in the attachment - password is "Pass"). In the workbook I have list of clients, the thing is some of these clients belong to a group(and shouldn't be contacted individualy). I would like to add an Group ID to each entry, the problem is that there are two ways how clients are "grouped" they either have a same facturation Nom. OR they have same adress+surname.
Is there a way how to do this?
I've been trying to figure this out for past several hours and it would be a great help.
Thanks

Paul_Hossler
02-14-2017, 02:34 PM
Something like this maybe




Option Explicit
Sub Macro1()
Dim r As Range, r1 As Range
Dim iGroup As Long, iRow As Long


Application.ScreenUpdating = False


With Worksheets("Source_Data")
Set r = .Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)


'column C --------------------------------------------------

With .Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

iGroup = 1

For iRow = 2 To r.Rows.Count - 1
If CLng(.Cells(iRow + 1, 3).Value) = CLng(.Cells(iRow, 3).Value) Then
If Len(.Cells(iRow, 7).Value) = 0 Then
.Cells(iRow, 7).Value = iGroup
.Cells(iRow + 1, 7).Value = iGroup

Else
.Cells(iRow + 1, 7).Value = .Cells(iRow, 7).Value
End If

ElseIf CLng(.Cells(iRow + 1, 3).Value) = CLng(.Cells(iRow + 2, 3).Value) Then
iGroup = iGroup + 1
End If
Next iRow


'columns D & E --------------------------------------------------

With .Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

For iRow = 2 To r.Rows.Count - 1
If .Cells(iRow + 1, 4).Value = .Cells(iRow, 4).Value And .Cells(iRow + 1, 5).Value = .Cells(iRow, 5).Value Then
If Len(.Cells(iRow, 7).Value) = 0 Then
.Cells(iRow, 7).Value = iGroup
.Cells(iRow + 1, 7).Value = iGroup

Else
.Cells(iRow + 1, 7).Value = .Cells(iRow, 7).Value
End If

ElseIf .Cells(iRow + 1, 4).Value = .Cells(iRow + 2, 4).Value And .Cells(iRow + 1, 5).Value = .Cells(iRow + 2, 5).Value Then
iGroup = iGroup + 1
End If
Next iRow
End With
Application.ScreenUpdating = True
End Sub

DavidWaldo
02-15-2017, 12:57 PM
Worked like a charm! Thanks very much.