How to copy paste from 1 cell to many cells as many as comma separators using excel VBA

A

amo

Board Regular
Joined
Apr 14, 2020
Messages
141
Office Version
  1. 2010
Platform
  1. Windows
I have the worksheet sheet1 below

Data 2.png



what I want :

Data 1.png



I use office 2010 , Windows 10

what I want :

  1. copy and paste in sheet 2, the amount is as much as the total Column B
  2. each column is separated by a comma
  3. For column A or image URLs, have been sorted as to the row
    example: if in column A for Black is in the first ,
    as well as in column C for the word Black is also in the first
  4. For column B, prices and stock are sequential and the total is dynamic according to the total color and size variation
    Example: for the color column there are 2, namely black and red and for the size column there are 3, namely 36, 37, 38
    the sum of all is 6
Anyone know how to copy as the above case ?

Thanks
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
How you get Color4 and Size4 at Result? I think they should be Red & 36 Not Black & 38?
 
Upvote 0
maabadi said:
How you get Color4 and Size4 at Result? I think they should be Red & 36 Not Black & 38?
Click to expand...
Oh, sorry

yes you are right, it should be red & 36

That's the data I wrote manually
 
Upvote 0
if your data is in Sheet1 and you want result at Sheet2 Try this:
VBA Code: 
Sub Test()
Dim i As Long, j As Long, K As Long, St As String, Lr As Long, Lc As Long
Dim Cn As Long, Sn As Long, m As Long, n As Long, p As Long, q As Long, r As Long
Dim m2 As Long, q2 As Long, r2 As Long, n2 As Long
With Sheets("Sheet1")
Lr = .Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A1:E1").Value = Array("Color1", "Size1", "Price1", "Stock1", "Url Image1")
For i = 2 To Lr
Cn = Len(.Range("C" & i)) - Len(Application.WorksheetFunction.Substitute(.Range("C" & i), ",", "")) + 1
Sn = Len(.Range("D" & i)) - Len(Application.WorksheetFunction.Substitute(.Range("D" & i), ",", "")) + 1
For j = 1 To Cn
If j = 1 Then
m = 1
q = 1
r = 1
Else
m = InStr(m + 1, .Range("C" & i).Value, ",")
q = InStr(q + 1, .Range("B" & i).Value, ",")
r = InStr(r + 1, .Range("A" & i).Value, ",")
End If
m2 = InStr(m + 1, .Range("C" & i).Value, ",")
If m2 = 0 Then m2 = Len(.Range("C" & i).Value) + 1
q2 = InStr(q + 1, .Range("B" & i).Value, ",")
If q2 = 0 Then q2 = Len(.Range("B" & i).Value) + 1
r2 = InStr(r + 1, .Range("A" & i).Value, ",")
If r2 = 0 Then r2 = Len(.Range("A" & i).Value) + 1
For K = 1 To Sn
If K = 1 Then
n = 1
Else
n = InStr(n + 1, .Range("D" & i).Value, ",")
End If
n2 = InStr(n + 1, .Range("D" & i).Value, ",") + 1
If n2 = 1 Then n2 = Len(.Range("D" & i).Value) + 1
St = St & "," & Mid(.Range("C" & i).Value, m, m2 - m)
St = St & "," & Mid(.Range("D" & i).Value, n, n2 - n)
St = St & "," & Replace(Mid(.Range("B" & i).Value, q, q2 - q), ":", ",")
St = St & "," & Mid(.Range("A" & i).Value, r, r2 - r)
Next K
Next j
St = Replace(Replace(Replace(St, " ", ""), ",,", ","), ",,", ",")
St = Right(St, Len(St) - 1)
Debug.Print St
Sheets("Sheet2").Range("A" & i).Resize(, Cn * Sn * 5).Value = Split(St, ",")
St = ""
Next i
End With
Lc = Sheets("Sheet2").Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
Sheets("Sheet2").Range("A1:E1").AutoFill Destination:=Range(Sheets("Sheet2").Cells(1, 1), Sheets("Sheet2").Cells(1, Lc)), Type:=xlFillDefault
St = Split(Cells(1, Lc).Address, "$")(1)
Sheets("Sheet2").Columns("A:" & St).AutoFit
End Sub
 
Upvote 0
@maabadi

thank you, perfect
but there are some problems

1. The size of the Url Image column is very wide, can it be made into a standard size?

2. If the image url is empty, an error message
"Object variable or With block variable not set"

3. The data is dynamic, can the column be made unchanged?
example: column A Color
column B size
etc


Screenshot_4.png
 
Upvote 0
1. Why I see at last image Cell C3 for Color & D4 for Size are Empty?
2. Do you want only add to Size for row 3 & Color for Row 4?
3. For Row 4, if answer is Yes, Why you have 3 set of Price But 2 color?
Try this only if Url image has empty cells:
VBA Code: 
Sub Test()
Dim i As Long, j As Long, K As Long, St As String, Lr As Long, Lc As Long
Dim Cn As Long, Sn As Long, m As Long, n As Long, p As Long, q As Long, r As Long
Dim m2 As Long, q2 As Long, r2 As Long, n2 As Long
Dim X1 As Long, X2 As Long, X3 As Long, X4 As Long, X5 As Long
With Sheets("Sheet1")
X1 = Application.WorksheetFunction.Match("Url image", .Range("A1:E1"), 0)
X2 = Application.WorksheetFunction.Match("Price and Stock", .Range("A1:E1"), 0)
X3 = Application.WorksheetFunction.Match("Color", .Range("A1:E1"), 0)
X4 = Application.WorksheetFunction.Match("Size", .Range("A1:E1"), 0)
Lr = .Cells(Rows.Count, X2).End(xlUp).Row
Sheets("Sheet2").Range("A1:E1").Value = Array("Color1", "Size1", "Price1", "Stock1", "Url Image1")
For i = 2 To Lr

Cn = Len(.Cells(i, X3)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X3), ",", "")) + 1
Sn = Len(.Cells(i, X4)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X4), ",", "")) + 1
For j = 1 To Cn
If j = 1 Then
m = 1
q = 1
r = 1
Else
m = InStr(m + 1, .Cells(i, X3).Value, ",")
q = InStr(q + 1, .Cells(i, X2).Value, ",")
r = InStr(r + 1, .Cells(i, X1).Value, ",")
End If
m2 = InStr(m + 1, .Cells(i, X3).Value, ",")
If m2 = 0 Then m2 = Len(.Cells(i, X3).Value) + 1
q2 = InStr(q + 1, .Cells(i, X2).Value, ",")
If q2 = 0 Then q2 = Len(.Cells(i, X2).Value) + 1
r2 = InStr(r + 1, .Cells(i, X1).Value, ",")
If r2 = 0 Then r2 = Len(.Cells(i, X1).Value) + 1
For K = 1 To Sn
If K = 1 Then
n = 1
Else
n = InStr(n + 1, .Cells(i, X4).Value, ",")
End If
n2 = InStr(n + 1, .Cells(i, X4).Value, ",") + 1
If n2 = 1 Then n2 = Len(.Cells(i, X4).Value) + 1
St = St & "," & Mid(.Cells(i, X3).Value, m, m2 - m)
St = St & "," & Mid(.Cells(i, X4).Value, n, n2 - n)
St = St & "," & Replace(Mid(.Cells(i, X2).Value, q, q2 - q), ":", ",")
If Len(.Cells(i, X1).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X1).Value, r, r2 - r)
Else
St = St & "," & "##"
End If
Next K
Next j
St = Replace(Replace(Replace(Replace(St, " ", ""), ",,", ","), ",,", ","), "##", "")
St = Right(St, Len(St) - 1)
Debug.Print St
Sheets("Sheet2").Range("A" & i).Resize(, Cn * Sn * 5).Value = Split(St, ",")
St = ""
Next i
End With
Lc = Sheets("Sheet2").Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
Sheets("Sheet2").Range("A1:E1").AutoFill Destination:=Range(Sheets("Sheet2").Cells(1, 1), Sheets("Sheet2").Cells(1, Lc)), Type:=xlFillDefault
St = Split(Cells(1, Lc).Address, "$")(1)
'Sheets("Sheet2").Columns("A:" & St).AutoFit
End Sub

And if Color & Size can be empty Try this:
VBA Code: 
Sub Test()
Dim i As Long, j As Long, K As Long, St As String, Lr As Long, Lc As Long
Dim Cn As Long, Sn As Long, m As Long, n As Long, p As Long, q As Long, r As Long
Dim m2 As Long, q2 As Long, r2 As Long, n2 As Long
Dim X1 As Long, X2 As Long, X3 As Long, X4 As Long, X5 As Long
With Sheets("Sheet1")
X1 = Application.WorksheetFunction.Match("Url image", .Range("A1:E1"), 0)
X2 = Application.WorksheetFunction.Match("Price and Stock", .Range("A1:E1"), 0)
X3 = Application.WorksheetFunction.Match("Color", .Range("A1:E1"), 0)
X4 = Application.WorksheetFunction.Match("Size", .Range("A1:E1"), 0)
Lr = .Cells(Rows.Count, X2).End(xlUp).Row
Sheets("Sheet2").Range("A1:E1").Value = Array("Color1", "Size1", "Price1", "Stock1", "Url Image1")
For i = 2 To Lr

Cn = Len(.Cells(i, X3)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X3), ",", "")) + 1
Sn = Len(.Cells(i, X4)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X4), ",", "")) + 1
For j = 1 To Cn
If j = 1 Then
m = 1
q = 1
r = 1
Else
m = InStr(m + 1, .Cells(i, X3).Value, ",")
q = InStr(q + 1, .Cells(i, X2).Value, ",")
r = InStr(r + 1, .Cells(i, X1).Value, ",")
End If
m2 = InStr(m + 1, .Cells(i, X3).Value, ",")
If m2 = 0 Then m2 = Len(.Cells(i, X3).Value) + 1
q2 = InStr(q + 1, .Cells(i, X2).Value, ",")
If q2 = 0 Then q2 = Len(.Cells(i, X2).Value) + 1
r2 = InStr(r + 1, .Cells(i, X1).Value, ",")
If r2 = 0 Then r2 = Len(.Cells(i, X1).Value) + 1
For K = 1 To Sn
If K = 1 Then
n = 1
Else
n = InStr(n + 1, .Cells(i, X4).Value, ",")
End If
n2 = InStr(n + 1, .Cells(i, X4).Value, ",") + 1
If n2 = 1 Then n2 = Len(.Cells(i, X4).Value) + 1
If Len(.Cells(i, X3).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X3).Value, m, m2 - m)
Else
St = St & "," & "##"
End If
If Len(.Cells(i, X4).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X4).Value, n, n2 - n)
Else
St = St & "," & "##"
End If
St = St & "," & Replace(Mid(.Cells(i, X2).Value, q, q2 - q), ":", ",")
If Len(.Cells(i, X1).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X1).Value, r, r2 - r)
Else
St = St & "," & "##"
End If
Next K
Next j
St = Replace(Replace(Replace(Replace(St, " ", ""), ",,", ","), ",,", ","), "##", "")
St = Right(St, Len(St) - 1)
Debug.Print St
Sheets("Sheet2").Range("A" & i).Resize(, Cn * Sn * 5).Value = Split(St, ",")
St = ""
Next i
End With
Lc = Sheets("Sheet2").Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
Sheets("Sheet2").Range("A1:E1").AutoFill Destination:=Range(Sheets("Sheet2").Cells(1, 1), Sheets("Sheet2").Cells(1, Lc)), Type:=xlFillDefault
St = Split(Cells(1, Lc).Address, "$")(1)
'Sheets("Sheet2").Columns("A:" & St).AutoFit
End Sub
 
Last edited:
Upvote 0
maabadi said:
1. Why I see at last image Cell C3 for Color & D4 for Size are Empty?
2. Do you want only add to Size for row 3 & Color for Row 4?
3. For Row 4, if answer is Yes, Why you have 3 set of Price But 2 color?
Try this only if Url image has empty cells:
VBA Code: 
Sub Test()
Dim i As Long, j As Long, K As Long, St As String, Lr As Long, Lc As Long
Dim Cn As Long, Sn As Long, m As Long, n As Long, p As Long, q As Long, r As Long
Dim m2 As Long, q2 As Long, r2 As Long, n2 As Long
Dim X1 As Long, X2 As Long, X3 As Long, X4 As Long, X5 As Long
With Sheets("Sheet1")
X1 = Application.WorksheetFunction.Match("Url image", .Range("A1:E1"), 0)
X2 = Application.WorksheetFunction.Match("Price and Stock", .Range("A1:E1"), 0)
X3 = Application.WorksheetFunction.Match("Color", .Range("A1:E1"), 0)
X4 = Application.WorksheetFunction.Match("Size", .Range("A1:E1"), 0)
Lr = .Cells(Rows.Count, X2).End(xlUp).Row
Sheets("Sheet2").Range("A1:E1").Value = Array("Color1", "Size1", "Price1", "Stock1", "Url Image1")
For i = 2 To Lr

Cn = Len(.Cells(i, X3)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X3), ",", "")) + 1
Sn = Len(.Cells(i, X4)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X4), ",", "")) + 1
For j = 1 To Cn
If j = 1 Then
m = 1
q = 1
r = 1
Else
m = InStr(m + 1, .Cells(i, X3).Value, ",")
q = InStr(q + 1, .Cells(i, X2).Value, ",")
r = InStr(r + 1, .Cells(i, X1).Value, ",")
End If
m2 = InStr(m + 1, .Cells(i, X3).Value, ",")
If m2 = 0 Then m2 = Len(.Cells(i, X3).Value) + 1
q2 = InStr(q + 1, .Cells(i, X2).Value, ",")
If q2 = 0 Then q2 = Len(.Cells(i, X2).Value) + 1
r2 = InStr(r + 1, .Cells(i, X1).Value, ",")
If r2 = 0 Then r2 = Len(.Cells(i, X1).Value) + 1
For K = 1 To Sn
If K = 1 Then
n = 1
Else
n = InStr(n + 1, .Cells(i, X4).Value, ",")
End If
n2 = InStr(n + 1, .Cells(i, X4).Value, ",") + 1
If n2 = 1 Then n2 = Len(.Cells(i, X4).Value) + 1
St = St & "," & Mid(.Cells(i, X3).Value, m, m2 - m)
St = St & "," & Mid(.Cells(i, X4).Value, n, n2 - n)
St = St & "," & Replace(Mid(.Cells(i, X2).Value, q, q2 - q), ":", ",")
If Len(.Cells(i, X1).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X1).Value, r, r2 - r)
Else
St = St & "," & "##"
End If
Next K
Next j
St = Replace(Replace(Replace(Replace(St, " ", ""), ",,", ","), ",,", ","), "##", "")
St = Right(St, Len(St) - 1)
Debug.Print St
Sheets("Sheet2").Range("A" & i).Resize(, Cn * Sn * 5).Value = Split(St, ",")
St = ""
Next i
End With
Lc = Sheets("Sheet2").Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
Sheets("Sheet2").Range("A1:E1").AutoFill Destination:=Range(Sheets("Sheet2").Cells(1, 1), Sheets("Sheet2").Cells(1, Lc)), Type:=xlFillDefault
St = Split(Cells(1, Lc).Address, "$")(1)
'Sheets("Sheet2").Columns("A:" & St).AutoFit
End Sub

And if Color & Size can be empty Try this:
VBA Code: 
Sub Test()
Dim i As Long, j As Long, K As Long, St As String, Lr As Long, Lc As Long
Dim Cn As Long, Sn As Long, m As Long, n As Long, p As Long, q As Long, r As Long
Dim m2 As Long, q2 As Long, r2 As Long, n2 As Long
Dim X1 As Long, X2 As Long, X3 As Long, X4 As Long, X5 As Long
With Sheets("Sheet1")
X1 = Application.WorksheetFunction.Match("Url image", .Range("A1:E1"), 0)
X2 = Application.WorksheetFunction.Match("Price and Stock", .Range("A1:E1"), 0)
X3 = Application.WorksheetFunction.Match("Color", .Range("A1:E1"), 0)
X4 = Application.WorksheetFunction.Match("Size", .Range("A1:E1"), 0)
Lr = .Cells(Rows.Count, X2).End(xlUp).Row
Sheets("Sheet2").Range("A1:E1").Value = Array("Color1", "Size1", "Price1", "Stock1", "Url Image1")
For i = 2 To Lr

Cn = Len(.Cells(i, X3)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X3), ",", "")) + 1
Sn = Len(.Cells(i, X4)) - Len(Application.WorksheetFunction.Substitute(.Cells(i, X4), ",", "")) + 1
For j = 1 To Cn
If j = 1 Then
m = 1
q = 1
r = 1
Else
m = InStr(m + 1, .Cells(i, X3).Value, ",")
q = InStr(q + 1, .Cells(i, X2).Value, ",")
r = InStr(r + 1, .Cells(i, X1).Value, ",")
End If
m2 = InStr(m + 1, .Cells(i, X3).Value, ",")
If m2 = 0 Then m2 = Len(.Cells(i, X3).Value) + 1
q2 = InStr(q + 1, .Cells(i, X2).Value, ",")
If q2 = 0 Then q2 = Len(.Cells(i, X2).Value) + 1
r2 = InStr(r + 1, .Cells(i, X1).Value, ",")
If r2 = 0 Then r2 = Len(.Cells(i, X1).Value) + 1
For K = 1 To Sn
If K = 1 Then
n = 1
Else
n = InStr(n + 1, .Cells(i, X4).Value, ",")
End If
n2 = InStr(n + 1, .Cells(i, X4).Value, ",") + 1
If n2 = 1 Then n2 = Len(.Cells(i, X4).Value) + 1
If Len(.Cells(i, X3).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X3).Value, m, m2 - m)
Else
St = St & "," & "##"
End If
If Len(.Cells(i, X4).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X4).Value, n, n2 - n)
Else
St = St & "," & "##"
End If
St = St & "," & Replace(Mid(.Cells(i, X2).Value, q, q2 - q), ":", ",")
If Len(.Cells(i, X1).Value) > 0 Then
St = St & "," & Mid(.Cells(i, X1).Value, r, r2 - r)
Else
St = St & "," & "##"
End If
Next K
Next j
St = Replace(Replace(Replace(Replace(St, " ", ""), ",,", ","), ",,", ","), "##", "")
St = Right(St, Len(St) - 1)
Debug.Print St
Sheets("Sheet2").Range("A" & i).Resize(, Cn * Sn * 5).Value = Split(St, ",")
St = ""
Next i
End With
Lc = Sheets("Sheet2").Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
Sheets("Sheet2").Range("A1:E1").AutoFill Destination:=Range(Sheets("Sheet2").Cells(1, 1), Sheets("Sheet2").Cells(1, Lc)), Type:=xlFillDefault
St = Split(Cells(1, Lc).Address, "$")(1)
'Sheets("Sheet2").Columns("A:" & St).AutoFit
End Sub
Click to expand...
1. yes,
Because the data is dynamic

2. Yes
3. Sorry there was a typo , the correct one is 2 sets for the price


there is an error message

Screenshot_6.png


Screenshot_5.png
 
Upvote 0
What is exact Header Name for Url image? Copy it from Cell and Paste it at code with "Url Image" at Yellow line at code? check don't have more space at the first or end of text also.
or Test this at your file and show result to me:
VBA Code: 
Sub Test5()
With Sheet1
MsgBox .Range("A1").Value & "&" & .Range("B1").Value & "&" & .Range("C1").Value & "&" & .Range("D1").Value & "&" & .Range("E1").Value
End With
End Sub
 
Upvote 0
maabadi said:
What is exact Header Name for Url image? Copy it from Cell and Paste it at code with "Url Image" at Yellow line at code? check don't have more space at the first or end of text also.
or Test this at your file and show result to me:
VBA Code: 
Sub Test5()
With Sheet1
MsgBox .Range("A1").Value & "&" & .Range("B1").Value & "&" & .Range("C1").Value & "&" & .Range("D1").Value & "&" & .Range("E1").Value
End With
End Sub
Click to expand...
oh yes,,,, because of the difference in Header Name
and now it's running

for lines 3 and 4 it's still not right

Screenshot_7.png
 
Upvote 0
1. Do you run 2nd Code at Post #6?
2. If yes, Do you correct number of Data Sets to match with Color & Size Numbers?
AND Please Run the Codes at Post #8 and paste result here.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Making the contents of the active cell the search term, and search using that term, copy paste row, next
Replies
2
Views
181
Travis Kunnen
T
B
  • Question
VBA Extract data from one Workbook and Transpose Paste to another
Replies
5
Views
902
DanteAmor
DanteAmor
P
  • Question
Copy non empty cells from the dynamic range column and paste to the bottom of data in table
Replies
0
Views
370
PitMax
P
I
  • Question
Move multiple rows from one table to another using conditional trigger
Replies
2
Views
469
ItsNursinTime
I
S
  • Question
VBA Copy range of data from multiple sheets & paste into single column of summary sheet
Replies
1
Views
464
Micron
M

Forum statistics

Threads
1,215,043
Messages
6,122,816
Members
449,095
Latest member
m_smith_solihull

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top