Combine Cells if Part of Header Matches

[Alphacsulb]

I've been doing this manually for a few years now and I hope this is possible to automate.

This data comes in from the customer and I have to combine their order by options. In this scenario they had 2 fields, Field0 and Field1.

Field0 order had the options ESCV and they ordered 200 of them.
Field1 order had the options ASR and they ordered 300 of them.

Here is the sample data I've described.

Sheet1

*	A	B	C	D	E	F	G	H	I
1	Field0 1	Field0 2	Field0 3	Field0 4	Field1 1	Field1 2	Field1 3	Field Qty0	Field Qty1
2	E	S	C	V	A	S	R	200	300
3	*	*	*	*	*	*	*	*	*
4	Desired Output:	*	*	*	*	*	*	*	*
5	*	*	*	*	*	*	*	*	*
6	Field0-ESCV	Field1-ASR	*	*	*	*	*	*	*
7	200	300	*	*	*	*	*	*	*

<colgroup><col style="font-weight:bold; width:30px; "><col style="width:99px;"><col style="width:87px;"><col style="width:71px;"><col style="width:71px;"><col style="width:71px;"><col style="width:71px;"><col style="width:71px;"><col style="width:77px;"><col style="width:77px;"></colgroup><tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4


Any leads would be appreciated.

 

[venkat1926]

You have entered only one row of data in sheet1 I presume there may be more rows.I have added anotherrow(row no. 3 with random data ) in sheet1 which is given below

Sheet1

*	A	B	C	D	E	F	G	H	I
1	Field0 1	Field0 2	Field0 3	Field0 4	Field1 1	Field1 2	Field1 3	Field Qty0	Field Qty1
2	E	S	C	V	A	S	R	200	300
3	A	S	D	F	G	H	J	400	500

<colgroup><col style="font-weight:bold; width:30px; "><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"><col style="width:64px;"></colgroup><tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4


now introduce this macro in vb editor of this file and run it and see the result in SHEET 2
add one or two sample rows in sheet 1 and again run the macro
feedback please

Sub test()
Dim cfind As Range


Dim hdng0 As String, hdng1 As String
Dim text0 As String, text1 As String
Dim j0 As Integer, j1 As Integer
Dim m As Integer, n As Integer, k As Integer
Dim qty(0 To 1) As Long
Worksheets("sheet2").Cells.Clear
hdng0 = "field0": hdng1 = "field1"
text0 = "fiedl0": text1 = "field1"
With Worksheets("sheet1")
j0 = WorksheetFunction.CountIf(.Cells(1, 1).EntireRow, hdng0 & "*")
j1 = WorksheetFunction.CountIf(.Cells(1, 1).EntireRow, hdng1 & "*")
'MSGBOX j0 & " " & j1
m = .Range("A1").End(xlDown).Row
For n = 2 To m


For k = 1 To j0
text0 = text0 & " " & .Cells(n, k)
Next k
'MSGBOX text0
qty(0) = .Cells(n, 1).End(xlToRight).Offset(0, -1).Value
qty(1) = .Cells(n, 1).End(xlToRight).Value
With Worksheets("sheet2")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = text0


.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = qty(0)
End With
For k = j0 + 1 To j0 + j1
text1 = text1 & " " & .Cells(n, k)
Next k
'MSGBOX text1
With Worksheets("sheet2")
.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = text1
.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = qty(1)
End With
text0 = "fiedl0": text1 = "field1"


Next n
End With


MsgBox "MACRO OVER SEE SHEET 2"






End Sub

 

[Alphacsulb]

Preliminary indications appear to correct. I'll report further as I test.

Thanks, I know this was a weird request.

 

[Alphacsulb]

Venkat,

There will always be just one row of data on row 2, and if possible I'd like to have the results in sheet1 starting on row 5 & 6.

I've attempted to modify the macro with my real-time data and got an error with a mismatch (Run-time Error 13) at this line:

I have a few questions that I commented on the macro. Please see below:

Sub CombineCells()
Dim cfind As Range


Dim hdng0 As String, hdng1 As String
Dim text0 As String, text1 As String
Dim j0 As Integer, j1 As Integer
Dim m As Integer, n As Integer, k As Integer
Dim qty(0 To 1) As Long
Worksheets("sheet2").Cells.Clear
hdng0 = "Opto-Instructions-1": hdng1 = "Opto-Instructions-2" 'Is this the header row?
text0 = "Opto-InstructionsQty 1": text1 = "Opto-InstructionsQty 2" 'Is this the data row?
With Worksheets("sheet1")
j0 = WorksheetFunction.CountIf(.Cells(1, 1).EntireRow, hdng0 & "*") 'I'm not sure what this is doing?
j1 = WorksheetFunction.CountIf(.Cells(1, 1).EntireRow, hdng1 & "*")
'MSGBOX j0 & " " & j1
m = .Range("A1").End(xlDown).Row
For n = 2 To m



For k = 1 To j0
text0 = text0 & " " & .Cells(n, k)
Next k
'MSGBOX text0
qty(0) = .Cells(n, 1).End(xlToRight).Offset(0, -1).Value 'This is where I get the error 13 Mismatch.
qty(1) = .Cells(n, 1).End(xlToRight).Value
With Worksheets("sheet2")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = text0


.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = qty(0)
End With
For k = j0 + 1 To j0 + j1
text1 = text1 & " " & .Cells(n, k)
Next k
'MSGBOX text1
With Worksheets("sheet2")
.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = text1
.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = qty(1)
End With
text0 = "Opto-InstructionsQty 1": text1 = "Opto-InstructionsQty 2" 'Is this the heading for what is currently going into Sheet 2?


Next n
End With

MsgBox "MACRO OVER SEE SHEET 2"

End Sub

This is the my real time data before with expected results. I have 6 fields in total but I figured I would just run the macro 3 times if needed.

Sheet1

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

1

Correction Envelope Qty 1

Correction Envelope Qty 2

Opto-Instructions-1 1

Opto-Instructions-2 1

Opto-Instructions-2 2

Opto-Instructions-3 1

Opto-Instructions-3 2

Opto-Instructions-4 1

Opto-Instructions-4 2

Opto-Instructions-5 1

Opto-Instructions-5 2

Opto-Instructions-6 1

Opto-Instructions-6 2

Opto-InstructionsQty 1

Opto-InstructionsQty 2

Opto-InstructionsQty 3

Opto-InstructionsQty 4

Opto-InstructionsQty 5

Opto-InstructionsQty 6

2

50

10

E

E

S

E

C

E

V

E

T

E

K

10200

200

500

150

150

800

3

4

5

Opto-Instructions-1 E

Opto-Instructions-2 ES

Opto-Instructions-3 EC

Opto-Instructions-4 EV

Opto-Instructions-5 ET

Opto-Instructions-6 EK

6

10200

200

500

150

150

800

<tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4

 

[venkat1926]

minor difference in configuration. I prepared a new macro testsone
result is in A10 down . you must kep this sheet as activesheet

try this amcro for thle new data

Sub testone()
Dim cfind As Range, cfind1 As Range
Dim hdng As String
Dim suffix As Integer
Dim amt As Long
Dim txt As String
Dim j As Integer
Dim dest As Range
Dim add As String
Dim hdng1 As String
hdng1 = "Opto-InstructionsQty"
Application.ScreenUpdating = False
Range(Range("a3"), Cells(Rows.Count, "A")).EntireRow.Delete






Set dest = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
txt = ""
hdng = "Opto-Instructions-"
For suffix = 1 To 6
Set cfind = Rows("1:1").Find(what:=hdng & suffix, lookat:=xlPart)
If Not cfind Is Nothing Then
add = cfind.Address


'MsgBox cfind.Address


txt = txt & "-" & hdng1 & "-" & suffix & " " & cfind.Offset(1, 0)
'MsgBox txt
Do
Set cfind = Rows("1:1").Cells.FindNext(cfind)
If cfind Is Nothing Then Exit Do
If cfind.Address = add Then Exit Do
'txt = txt & "-" & suffix & cfind.Offset(1, 0)
txt = txt & " " & cfind.Offset(1, 0)
'MsgBox txt
Loop


Set cfind1 = Rows("1:1").Find(what:=hdng1 & " " & suffix, lookat:=xlWhole)
If Not cfind1 Is Nothing Then
'add = cfind1.Address
'MsgBox cfind1.Address
'txt = txt & cfind.Offset(1, 0)
'MsgBox txt
amt = cfind1.Offset(1, 0)
End If
Set dest = Range("A10").Offset(0, suffix - 1)
'MsgBox dest.Address




'MsgBox txt


'MsgBox txt
txt = Right(txt, Len(txt) - 1)
'MsgBox txt


dest = txt
dest.Offset(1, 0) = amt


'Set dest = dest.Offset(0, j)
End If
txt = ""
Next suffix


MsgBox "macro Over"


Application.ScreenUpdating = True


End Sub

 

[venkat1926]

the data and output for a few colulmns are given here for you rperusal
for testing the maclro you can again run the macro "testone"

Excel Workbook
	A	B	C	D	E	F	G
1	Correction Envelope Qty 1	Correction Envelope Qty 2	Opto-Instructions-1 1	Opto-Instructions-2 1	Opto-Instructions-2 2	Opto-Instructions-3 1	Opto-Instructions-3 2
2	50	10	E	E	S	E	C
3
4
5
6
7
8
9
10	Opto-InstructionsQty-1 E	Opto-InstructionsQty-2 E S	Opto-InstructionsQty-3 E C	Opto-InstructionsQty-4 E V	Opto-InstructionsQty-5 E T	Opto-InstructionsQty-6 E K
11	10200	200	500	150	150	800
12
Sheet1

 

[Alphacsulb]

Fantastic! Thank you for your help.