Special sum of texts

B

Bartosz

Hello,

I try to write macro which will sum text in new column, but in special way,
but it is to complicated for me. How is should works:
- when in data3 or data4 is bbxx (when xx is 01,02 …) then in column SUM for
all line containing this data should be bbxx
- when in data2 is aax and data3, data4 are empty then SUM is aax
- when in data 3 or 4 cccxx and data2 is empty then SUM is cccxx
- when in data 3 or 4 is bbxx and in data3 and data4 is cccxx then SUM for
all line containing this data is cccxx
- when in data3 or 4 is cccxx and in data 3 or 4 is cccxy for all this line
SUM is cccxx+cccxy
- when in data2 is aaxx and is data3 or 4 is cccxx then in all line SUM is
cccxx
- when in data2 is aaxx and aaxy and in data3 or 4 is cccxx and cccxy then
SUM is cccxx+cccxy
Example
data1 data2 data3 data4 SUM
1
2 bb01 bb01
3 bb01 bb01
4 ccc02 ccc02
5 ccc06 ccc06+ccc07
6 ccc02 ccc02
7 ccc06 ccc07 ccc06+ccc07
8 ccc07 ccc06+ccc07
9 ccc07 ccc06+ccc07
10 bb02 ccc01
11 ccc01 bb02 ccc02
12 cc01 ccc03
13 ccc03 ccc03
14 aa1 ccc03 ccc03
15 aa1 ccc03
16 aa2 ccc04 ccc04+ccc05
17 aa3 ccc04 ccc04+ccc05
18 aa2 ccc05 ccc04+ccc05
19 aa3 ccc05 ccc04+ccc05
20 aa4 aa4
21 aa4 aa4

All this connections can be joint together like here:

22 bb03 ccc08+ccc09+ccc10
23 bb03 ccc10 ccc08+ccc09+ccc10
24 ccc10 ccc08+ccc09+ccc10
25 ccc09 ccc08+ccc09+ccc10
26 ccc08 ccc08+ccc09+ccc10
27 aa5 ccc08 ccc08+ccc09+ccc10
28 aa5 ccc09 ccc08+ccc09+ccc10
29 aa5 ccc10 ccc08+ccc09+ccc10

Best Regards,
Bartosz
 
J

Joel

Try this

Sub SumData()

'Get Last row
LastRow = 0
For ColCount = 2 To 4
LRow = Cells(Rows.Count, ColCount).End(xlUp).Row
If LRow > LastRow Then
LastRow = LRow
End If
Next ColCount

For RowCount = 1 To LastRow
If Range("C" & RowCount) = "" And _
Range("D" & RowCount) = "" Then

If UCase(Left(Range("B" & RowCount), 2)) = "AA" Then
Range("E" & RowCount) = Range("B" & RowCount)
End If
Else
If UCase(Left(Range("C" & RowCount), 3)) = "CCC" Or _
UCase(Left(Range("D" & RowCount), 3)) = "CCC" Then

If UCase(Left(Range("C" & RowCount), 3)) = "CCC" Then
Range("E" & RowCount) = Range("C" & RowCount)
End If
If UCase(Left(Range("D" & RowCount), 3)) = "CC" Then
If Range("E" & RowCount) <> "" Then
Range("E" & RowCount) = Range("E" & RowCount) & "+"
End If
Range("E" & RowCount) = _
Range("E" & RowCount) & Range("D" & RowCount)
End If
Else
If UCase(Left(Range("C" & RowCount), 2)) = "BB" Or _
UCase(Left(Range("D" & RowCount), 2)) = "BB" Then

If UCase(Left(Range("C" & RowCount), 2)) = "BB" Then
Range("E" & RowCount) = Range("C" & RowCount)
End If
If UCase(Left(Range("D" & RowCount), 2)) = "BB" Then
If Range("E" & RowCount) <> "" Then
Range("E" & RowCount) = Range("E" & RowCount) & "+"
End If
Range("E" & RowCount) = _
Range("E" & RowCount) & Range("D" & RowCount)
End If
End If
End If
End If
Next RowCount

End Sub
 
B

Bartosz

Thanks for try, but it takie only one line to find konections, but the same
name differend rows is thesame thing, so Your macro took only information
from one row, but this macro have to look for data in all rows.
I try ta add ma table onece again with infromation which I got after Your
macro run.

Your_macro Correct_SUM
1 bb01 bb01 bb01
2 bb01 bb01 bb01
3 ccc02 ccc02 ccc02
4 ccc02 ccc02
5 ccc06 ccc06 ccc06+ccc07
6 ccc06 ccc07 ccc06 ccc06+ccc07
7 ccc07 ccc07 ccc06+ccc07
8 ccc07 ccc06+ccc07
9 bb02 bb02 ccc01
10 ccc01 bb02 ccc01 ccc02
11 cc01 ccc03
12 ccc03 ccc03 ccc03
13 aa1 ccc03 ccc03
14 aa1 aa1 ccc03
15 aa2 ccc04 ccc04 ccc04+ccc05
16 aa3 ccc05 ccc04+ccc05
17 aa2 ccc05 ccc05 ccc04+ccc05
18 aa3 ccc05 ccc04+ccc05
19 aa4 aa4 aa4
20 aa4 aa4 aa4

„Joel†pisze:
 
J

Joel

I don't see the pattern in your data. I would need a much better description
of you requirements before I could accurately complete this task.
 
B

Bartosz

Hi,
Thanks for answering, what this table contains data:
Column Data1 is components,
Data2 semi products named aaxx
Data3 and Data4 contain semi products contain name bbxx and cccxxx

For simplest cases:
If there is only bbxx and in any other row with bbxx there is nothing more
in column Data2, Data3 and Data4 the sum is bbxx
Data1 Data2 Data3 Data4 Correct_SUM
1 bb01 bb01
2 bb01 bb01

If there is only cccxx and in any other row with cccxx there is nothing more
in column Data2, Data3 and Data4 the sum is bbxx
3 ccc02 ccc02
4 ccc02 ccc02

For aax in column Data2 and nothing more in data3 and Data4 the sum is aax
19 aa4 aa4
20 aa4 aa4

Of there is cccxx and in one with rows with cccxx is cccyy the sum for all
rows with cccxx and cccyy is cccxx+cccyy (I add "*" to show row with
connections)
5 ccc06 ccc06+ccc07
6* ccc06 ccc07 ccc06+ccc07
7 ccc07 ccc06+ccc07
8 ccc07 ccc06+ccc07

In Case when data3 and data4 contani cccxx and in one row with cccxx is bbxx
then sum is only mane cccxx
9 bb02 ccc01
10* ccc01 bb02 ccc01
11 ccc01 ccc01

Similar in case with aaxx in Data2 and cccxxin column Data3 or Data4
12 ccc03 ccc03
13* aa1 ccc03 ccc03
14 aa1 ccc03

And one with complicated situation column Data3 or data4 contain cccxx and
cccyy and in the same row in column Data2 contain aaxx for both cccxx and
cccyy
15 aa2 ccc04 ccc04+ccc05
16 aa3 ccc05 ccc04+ccc05
17 aa2 ccc05 ccc04+ccc05
18 aa3 ccc05 ccc04+ccc05

Another situation ccc06 join with ccc07 and ccc08 with ccc09, but i the same
time ccc06 connect with aa5 which is connected with ccc08, and second
ccc07-aa7-ccc09
22 aa5 ccc06 ccc06+ccc07+ccc08+ccc09
23 aa6 ccc06 ccc07 ccc06+ccc07+ccc08+ccc09
24 aa7 ccc07 ccc06+ccc07+ccc08+ccc09
25 aa8 ccc06 ccc06+ccc07+ccc08+ccc09
26 aa5 ccc08 ccc06+ccc07+ccc08+ccc09
27 aa6 ccc08 ccc09 ccc06+ccc07+ccc08+ccc09
28 aa7 ccc09 ccc06+ccc07+ccc08+ccc09
29 aa8 ccc08 ccc06+ccc07+ccc08+ccc09

So only when bbxx or aaxx is alone then is sum there is bbxx or aaxx, but
when this manes is with name cccxx only cccxx is in sum. Connections between
cccxx and cccyy make sum cccxx+cccyy.
Now I do it manually but for long sum of cccxx (once I got 18 cccxx is SUM -
similar to last example with ccc06+ccc07+ccc08+ccc09) I could make mistake.


„Joel†pisze:
 
J

Joel

What are the requirements for row being connected? This must be resolved
before anything alse is done.
 
B

bartbory

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
component connect two semi products.
In ma last mail connections are for components 6, 10, 13, and all with
last two examples.

Bartosz
 
J

Joel

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads


Top