I will try it tomorrow.My code does what you asked for in post #28.
Did you at least try it?
OK, so now that you are looking at Contact, you are getting duplicates because the duplicate contacts for a customer are not necessarily beside each other. It is more like my second image in post #17.See results above.
Sub Rearrange_v3()
Dim a As Variant, b As Variant, aOriginal As Variant
Dim i As Long, r As Long, c As Long, MaxCols As Long
With Range("A1", Range("C" & Rows.Count).End(xlUp))
aOriginal = .Value
.Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(3), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
a = .Value
ReDim b(1 To UBound(a), 1 To 2)
For i = 2 To UBound(a)
If a(i, 1) <> a(i - 1, 1) Then
r = r + 1
b(r, 1) = a(i, 1)
b(r, 2) = a(i, 3)
c = 2
Else
If a(i, 3) <> a(i - 1, 3) Then
c = c + 1
If c > MaxCols Then
MaxCols = c
ReDim Preserve b(1 To UBound(b), 1 To MaxCols)
End If
b(r, c) = a(i, 3)
End If
End If
Next i
.Value = aOriginal
End With
With Range("E1").Resize(, MaxCols)
.Formula = "=""Contact ""&COLUMNS($E1:E1)-1"
.Value = .Value
.Cells(1).ClearContents
.Offset(1).Resize(r).Value = b
.EntireColumn.AutoFit
End With
End Sub
Gerrit.B 2020-07-14 1.xlsm | |||||||||
---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | |||
1 | Customer | Invoice | Contact | Contact 1 | Contact 2 | ||||
2 | Customer 1 | 55 | 1 | Customer 1 | 1 | ||||
3 | Customer 2 | 56 | 2 | Customer 2 | 2 | 3 | |||
4 | Customer 2 | 56 | 3 | Customer 4 | 4 | ||||
5 | Customer 2 | 57 | 2 | ||||||
6 | Customer 2 | 57 | 3 | ||||||
7 | Customer 4 | 60 | 4 | ||||||
Sheet2 |
Sub RowsToColumns_1()
Dim a As Variant, dic1 As Object, dic2 As Object
Dim i As Long, j As Long, k As Long
Application.DisplayAlerts = False
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
a = Range("A2:G" & Range("A" & Rows.Count).End(3).Row).Value
For i = 1 To UBound(a, 1)
If Not dic1.exists(a(i, 1)) Then
dic1(a(i, 1)) = a(i, 3)
Else
If Not dic2.exists(a(i, 1) & "|" & a(i, 3)) Then dic1(a(i, 1)) = dic1(a(i, 1)) & "|" & a(i, 3)
End If
dic2(a(i, 1) & "|" & a(i, 3)) = Empty
Next
With Range("E2")
.Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
.Offset(, 1).Resize(dic1.Count).TextToColumns .Offset(, 1), xlDelimited, Other:=True, OtherChar:="|"
.Offset(-1, 1).Value = "Contact 1"
.Offset(-1, 1).Resize(1, Rows(.Row & ":" & .Row + dic1.Count + 1).Find("*", , xlValues, 2, 2, 2).Column - .Column).DataSeries 1, 4, 1
End With
End Sub
Dante Amor | ||||||||||
---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | |||
1 | Customer | Invoice | Contact | Contact 1 | Contact 2 | |||||
2 | Customer 1 | 55 | 1 | Customer 1 | 1 | |||||
3 | Customer 2 | 56 | 2 | Customer 2 | 2 | 3 | ||||
4 | Customer 2 | 56 | 3 | Customer 4 | 4 | |||||
5 | Customer 2 | 57 | 2 | |||||||
6 | Customer 2 | 57 | 3 | |||||||
7 | Customer 4 | 60 | 4 | |||||||
8 | ||||||||||
Sheet1 |
ADVERTISEMENT
Sub Rearrange_v4()
Dim d As Object
Dim a As Variant
Dim i As Long
a = Range("A1", Range("C" & Rows.Count).End(xlUp)).Value
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a)
If InStr(1, ";" & d(a(i, 1)), ";" & a(i, 3) & ";", 1) = 0 Then d(a(i, 1)) = d(a(i, 1)) & a(i, 3) & ";"
Next i
With Range("E2:F2").Resize(d.Count)
.Value = Application.Transpose(Array(d.Keys, d.Items))
.Columns(2).TextToColumns , xlDelimited, , , False, True, False, False, False
.Cells(0, 2).Value = "Contact 1"
.Cells(0, 2).AutoFill .Cells(0, 2).Resize(, .CurrentRegion.Columns.Count - 1)
End With
End Sub
MailToList - Copy.xlsm | |||||||||
---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | |||
1 | Company | Invoice | Email Contact | Order. | DueDate | Contact | PO. | ||
2 | Company 1 | 11 | John@samplemail.com | 316 | 08/07/2020 | John | 3476 | ||
3 | Company 2 | 12 | Peter@samplemail.com | 299 | 20/07/2020 | Peter | 3289 | ||
4 | Company 2 | 12 | Alan@samplemail.com | 299 | 20/07/2020 | Alan | 3289 | ||
5 | Company 3 | 15 | Mick@samplemail.com | 251 | 05/03/2020 | Mick | 2761 | ||
6 | Company 4 | 16 | Jason@samplemail.com | 438 | 06/02/2020 | Jason | 4818 | ||
7 | Company 4 | 16 | Daisy@samplemail.com | 438 | 06/02/2020 | Daisy | 4818 | ||
8 | Company 4 | 17 | Jason@samplemail.com | 440 | 06/02/2020 | Jason | 4840 | ||
9 | Company 4 | 17 | Daisy@samplemail.com | 440 | 06/02/2020 | Daisy | 4840 | ||
10 | Company 5 | 18 | Robbert@samplemail.com | 426 | 20/07/2020 | Robbert | 4686 | ||
RemindersByExcel1 |
MailToList - Copy.xlsm | |||||||||||||||||||||||||||||
---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z | AA | |||
1 | Company | Contact1 | Contact2 | Contact3 | Contact4 | Contact5 | Email1 | Email2 | Email3 | Email4 | Email5 | Invoice1 | Invoice2 | Invoice3 | Invoice4 | Invoice5 | Order1 | Order2 | Order3 | Order4 | Order5 | PO1 | PO2 | PO3 | PO4 | PO5 | DueDate | ||
2 | Company 1 | John | John@samplemail.com | 11 | 316 | 3476 | 08/07/2020 | ||||||||||||||||||||||
3 | Company 2 | Peter | Alan | Peter@samplemail.com | Alan@samplemail.com | 12 | 299 | 3289 | 20/07/2020 | ||||||||||||||||||||
4 | Company 3 | Mick | Jason | Mick@samplemail.com | 15 | 251 | 2761 | 05/03/2020 | |||||||||||||||||||||
5 | Company 4 | Jason | Daisy | Jason@samplemail.com | Daisy@samplemail.com | 16 | 17 | 438 | 440 | 4818 | 4840 | 06/02/2020 | |||||||||||||||||
6 | Company 5 | Robbert | Robbert@samplemail.com | 18 | 426 | 4686 | 20/07/2020 | ||||||||||||||||||||||
Mail |
ADVERTISEMENT
Option Explicit
Option Base 1
Sub Rearrange_v5()
Dim a As Variant, b As Variant, ColOrder As Variant
Dim i As Long, j As Long, c As Long, Col As Long, k As Long
ColOrder = Array(6, 3, 2, 4, 7, 5)
With Sheets("RemindersByExcel1")
a = .Range("A1", .Range("G" & .Rows.Count).End(xlUp)).Value
End With
ReDim b(1 To UBound(a), 1 To 27)
For i = 2 To UBound(a)
If a(i, 1) <> a(i - 1, 1) Then
k = k + 1
b(k, 1) = a(i, 1)
End If
For c = 1 To 5
Col = ColOrder(c)
For j = 0 To 4
If LCase(b(k, c * 5 - 3 + j)) = LCase(a(i, Col)) Then
Exit For
ElseIf Len(b(k, c * 5 - 3 + j)) = 0 Then
b(k, c * 5 - 3 + j) = a(i, Col)
Exit For
End If
Next j
Next c
If a(i, ColOrder(6)) < b(k, 27) Or Len(b(k, 27)) = 0 Then b(k, 27) = a(i, ColOrder(6))
Next i
With Sheets("Mail")
.UsedRange.Offset(1).ClearContents
.Range("A2").Resize(k, 27).Value = b
End With
End Sub
Assuming ..
.. try
- Data on 'RemindersByExcel1' is sorted by Company
- 'Mail' sheet already has the headings in A1:AA1 and any other existing data on that sheet can be removed
VBA Code:Option Explicit Option Base 1 Sub Rearrange_v5() Dim a As Variant, b As Variant, ColOrder As Variant Dim i As Long, j As Long, c As Long, Col As Long, k As Long ColOrder = Array(6, 3, 2, 4, 7, 5) With Sheets("RemindersByExcel1") a = .Range("A1", .Range("G" & .Rows.Count).End(xlUp)).Value End With ReDim b(1 To UBound(a), 1 To 27) For i = 2 To UBound(a) If a(i, 1) <> a(i - 1, 1) Then k = k + 1 b(k, 1) = a(i, 1) End If For c = 1 To 5 Col = ColOrder(c) For j = 0 To 4 If LCase(b(k, c * 5 - 3 + j)) = LCase(a(i, Col)) Then Exit For ElseIf Len(b(k, c * 5 - 3 + j)) = 0 Then b(k, c * 5 - 3 + j) = a(i, Col) Exit For End If Next j Next c If a(i, ColOrder(6)) < b(k, 27) Or Len(b(k, 27)) = 0 Then b(k, 27) = a(i, ColOrder(6)) Next i With Sheets("Mail") .UsedRange.Offset(1).ClearContents .Range("A2").Resize(k, 27).Value = b End With End Sub