About Us

Bartosz

Thanks!
Works great!!!

Best Regards,
Bartosz

€žJoel€ pisze:

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:D" & 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:D").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

" wrote:

Hi,
If there are the same names in different rows is mean, that this
components are in one semi product, if in one row is more that one
name is mean that this component is in both semi products, so this

Thread Tools	Search this Thread
Show Printable Version	Search this Thread: Advanced Search
Display Modes
Switch to Linear Mode Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Counting texts	computexcel	Excel Discussion (Misc queries)	2	August 24th 08 12:56 AM
SUMIF for texts	Pieter	Excel Worksheet Functions	3	August 20th 08 10:19 AM
Concatenation 2 Texts	Hi_no_Tori	Excel Discussion (Misc queries)	8	September 21st 06 06:16 AM
Combo Box Texts	CeePeeuk	Excel Discussion (Misc queries)	1	January 17th 06 03:35 PM
Using Texts in Cells	Duncan	Excel Discussion (Misc queries)	4	October 14th 05 11:26 AM

Menu

About Us