The code assumes the data is on sheet 1. If not change the line below
Set DataSht = Sheets("Sheet1")
I create a new worksheet called Combinations. This is a lookup table with
the code to look up in column A. Column B - D are the combine codes. It was
very difficult to combine the codes.. Once the codes where combined the rest
of the code was pretty simple. All I do is to go down every row of your
original data. I look for any code in columns B - D (all the codes on any
row will have identical data in the combinations sheet). I take this code
and go to the combinations worksheet and find the code in column A. then if
there is data in the "CCC" column I put the data in column E of your orignal
data. If there is no CCC data then I check if there is BBB data. If there
isn't BB data then I take the AA data.
Sub SumData()
Dim ComSht As Worksheet
Dim DataRange As Range
'Create Combination sheet if one doesn't exist
Found = False
For Each sht In Sheets
If sht.Name = "Combinations" Then
Found = True
Exit For
End If
Next sht
If Found = True Then
Set ComSht = Sheets("Combinations")
Else
Set ComSht = Worksheets.Add( _
after:=Worksheets(Worksheets.Count))
ComSht.Name = "Combinations"
End If
Set DataSht = Sheets("Sheet1")
'Get Last row
LastRow = 0
For ColCount = 2 To 4
LRow = DataSht.Cells(Rows.Count, ColCount).End(xlUp).Row
If LRow > LastRow Then
LastRow = LRow
End If
Next ColCount
Set DataRange = DataSht.Range("B2
" & LastRow)
Call GetUniqueCodes(ComSht, DataRange)
Call GetCombinations(ComSht, DataRange)
With DataSht
For RowCount = 2 To LastRow
'Get Code Row
'find first column with data
ColNum = 0
For ColCount = 2 To 4
If .Cells(RowCount, ColCount) <> "" Then
ColNum = ColCount
End If
Next ColCount
'skip rows with no data
If ColNum > 0 Then
code = .Cells(RowCount, ColNum)
'get row number of code on combination Sheet
Set c = ComSht.Columns("A").Find(what:=code, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Can't find code")
Stop
Else
If c.Offset(0, 3) <> "" Then
.Range("E" & RowCount) = c.Offset(0, 3)
Else
If c.Offset(0, 2) <> "" Then
.Range("E" & RowCount) = c.Offset(0, 2)
Else
.Range("E" & RowCount) = c.Offset(0, 1)
End If
End If
End If
End If
Next RowCount
End With
End Sub
Sub GetUniqueCodes(ComSht As Worksheet, DataRange As Range)
With ComSht
.Cells.ClearContents
'copy codes to column a
Set CopyRange = Range(DataRange(1, 1), _
DataRange(DataRange.Rows.Count, 1))
CopyRange.Copy Destination:=.Range("A2")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
Set CopyRange = Range(DataRange(1, 2), _
DataRange(DataRange.Rows.Count, 2))
CopyRange.Copy Destination:=.Range("A" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
Set CopyRange = Range(DataRange(1, 3), _
DataRange(DataRange.Rows.Count, 3))
CopyRange.Copy Destination:=.Range("A" & NewRow)
'sort data in reverse order to get rid of blank cells
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set SortRange = .Range("A2:A" & LastRow)
SortRange.Sort _
key1:=.Range("A2"), _
order1:=xlDescending
'sort data in normal order
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set SortRange = .Range("A2:A" & LastRow)
SortRange.Sort _
key1:=.Range("A2"), _
order1:=xlAscending
'use advance filter to get unique items
SortRange.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=SortRange.Offset(0, 1), _
unique:=True
'delete column A so unique values are now in column A
.Columns("A").Delete
'get rid of extra value left by advance filter
If .Range("A2") = .Range("A3") Then
.Rows(2).Delete
End If
End With
End Sub
Sub GetCombinations(ComSht As Worksheet, DataRange As Range)
Dim RowRange As Range
With ComSht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
'Copy Unique values from column a to Row 1
Set CopyRange = .Range("A2:A" & LastRow)
CopyRange.Copy
.Range("B1").PasteSpecial _
Transpose:=True
'combination sheet will be a lookup table
'Colunmn A with be the lookup value (code)
'Put code in the diagnal so the code will be part of the combination
For RowCount = 2 To LastRow
.Cells(RowCount, RowCount) = .Range("A" & RowCount)
Next RowCount
For RowCount = 2 To DataRange.Rows.Count
If DataRange(RowCount, 1) <> "" And _
DataRange(RowCount, 2) <> "" Then
Code1 = DataRange(RowCount, 1)
Code2 = DataRange(RowCount, 2)
Row1 = .Columns("A").Find(what:=Code1, _
LookIn:=xlValues, lookat:=xlWhole).Row
Row2 = .Columns("A").Find(what:=Code2, _
LookIn:=xlValues, lookat:=xlWhole).Row
'Lookup table is symetrical so row number
'and column number are identical
'put each code in the other code row
.Cells(Row1, Row2) = Code2
.Cells(Row2, Row1) = Code1
End If
If DataRange(RowCount, 1) <> "" And _
DataRange(RowCount, 3) <> "" Then
Code1 = DataRange(RowCount, 1)
Code3 = DataRange(RowCount, 3)
Row1 = .Columns("A").Find(what:=Code1, _
LookIn:=xlValues, lookat:=xlWhole).Row
Row3 = .Columns("A").Find(what:=Code3, _
LookIn:=xlValues, lookat:=xlWhole).Row
'Lookup table is symetrical so row number
'and column number are identical
'put each code in the other code row
.Cells(Row1, Row3) = Code3
.Cells(Row3, Row1) = Code1
End If
If DataRange(RowCount, 2) <> "" And _
DataRange(RowCount, 3) <> "" Then
Code2 = DataRange(RowCount, 2)
Code3 = DataRange(RowCount, 3)
Row2 = .Columns("A").Find(what:=Code2, _
LookIn:=xlValues, lookat:=xlWhole).Row
Row3 = .Columns("A").Find(what:=Code3, _
LookIn:=xlValues, lookat:=xlWhole).Row
'Lookup table is symetrical so row number
'and column number are identical
'put each code in the other code row
.Cells(Row2, Row3) = Code3
.Cells(Row3, Row2) = Code2
End If
Next RowCount
'fill in table with all combinations
For RowCount1 = 2 To LastRow
For ColCount1 = 2 To (LastRow - 1)
For ColCount2 = ColCount1 To LastRow
Data1 = .Cells(RowCount1, ColCount1)
Data2 = .Cells(RowCount1, ColCount2)
If Data1 <> "" And Data2 <> "" Then
For RowCount2 = 2 To LastRow
If RowCount1 <> RowCount2 Then
If .Cells(RowCount2, ColCount1) <> "" Then
.Cells(RowCount2, ColCount2) = Data2
End If
If .Cells(RowCount2, ColCount2) <> "" Then
.Cells(RowCount2, ColCount1) = Data1
End If
End If
Next RowCount2
End If
Next ColCount2
Next ColCount1
Next RowCount1
'combine codes into 3 new columns
.Columns("B
").Insert
First_A_Col = 5
Last_A_Col = First_A_Col
Do While UCase(Left(.Cells(1, Last_A_Col + 1), 1)) = "A"
Last_A_Col = Last_A_Col + 1
Loop
First_B_Col = Last_A_Col + 1
Last_B_Col = First_B_Col
Do While UCase(Left(.Cells(1, Last_B_Col + 1), 1)) = "B"
Last_B_Col = Last_B_Col + 1
Loop
First_C_Col = Last_B_Col + 1
Last_C_Col = First_C_Col
Do While UCase(Left(.Cells(1, Last_C_Col + 1), 1)) = "C"
Last_C_Col = Last_C_Col + 1
Loop
'combine code into a string
For RowCount = 2 To LastRow
Set RowRange = .Range(.Cells(RowCount, First_A_Col), _
.Cells(RowCount, Last_A_Col))
.Range("B" & RowCount) = CombineCodes(RowRange)
Set RowRange = .Range(.Cells(RowCount, First_B_Col), _
.Cells(RowCount, Last_B_Col))
.Range("C" & RowCount) = CombineCodes(RowRange)
Set RowRange = .Range(.Cells(RowCount, First_C_Col), _
.Cells(RowCount, Last_C_Col))
.Range("D" & RowCount) = CombineCodes(RowRange)
Next RowCount
End With
End Sub
Function CombineCodes(Target As Range) As String
CombineCodes = ""
For Each cell In Target
If cell <> "" Then
If CombineCodes = "" Then
CombineCodes = cell
Else
CombineCodes = CombineCodes & "+" & cell
End If
End If
Next cell
End Function
