Excel Macro to copy data in cell to multiple cells in the same row

[xlstarter]

Hi I am a beginner in VBA scripting but I am working on a sheet where I want to copy data in one cell to multiple cells in the same row as long as it is not empty but separate the two data by a comma and do this through out the table

Before Macro

[TABLE="width: 256"]
<tbody>[TR]
[TD="width: 64"]A[/TD]
[TD="width: 64"]B[/TD]
[TD="width: 64"]C[/TD]
[TD="width: 64"]D[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 256"]
<tbody>[TR]
[TD="width: 64"]a[/TD]
[TD="width: 64"]d[/TD]
[TD="width: 64"][/TD]
[TD="width: 64"][/TD]
[/TR]
[TR]
[TD]b[/TD]
[TD]d[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]c[/TD]
[TD]d[/TD]
[TD]p[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]d[/TD]
[TD]e[/TD]
[TD]o[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]e[/TD]
[TD]f[/TD]
[TD]g[/TD]
[TD]l[/TD]
[/TR]
[TR]
[TD]f[/TD]
[TD]e[/TD]
[TD]x[/TD]
[TD]f[/TD]
[/TR]
</tbody>[/TABLE]

Here is what I mean: I want the data in Column A (if there is data) to be duplicated through the row separated by a comma and possibly delete column A. I tried to use do-while loop with a formula but my issue is that the sheet is not fixed, meaning the length of rows and columns might vary depending on when the report is generated and I do this task weekly, some help in automating this will be a great help.

After Macro

[TABLE="width: 256"]
<tbody>[TR]
[TD="class: xl65, width: 64"]<s>A</s>[/TD]
[TD="width: 64"]B[/TD]
[TD="width: 64"]C[/TD]
[TD="width: 64"]D[/TD]
[/TR]
[TR]
[TD="class: xl65"]<s>a</s>[/TD]
[TD]a,d[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"]<s>b</s>[/TD]
[TD]b,d[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"]<s>c</s>[/TD]
[TD]c,d[/TD]
[TD]c,p[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"]<s>d</s>[/TD]
[TD]d,e[/TD]
[TD]d,o[/TD]
[TD][/TD]
[/TR]
[TR]
[TD="class: xl65"]<s>e</s>[/TD]
[TD]e,f[/TD]
[TD]e,g[/TD]
[TD]e,l[/TD]
[/TR]
[TR]
[TD="class: xl65"]<s>f</s>[/TD]
[TD]f,e[/TD]
[TD]f,x[/TD]
[TD]f,f[/TD]
[/TR]
</tbody>[/TABLE]

 

[alansidman]

Try this:

Option Explicit


Sub xlstarter()
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Dim lc As Long
Dim i As Long
Dim j As Long


For i = 1 To lr
lc = Cells(i, Columns.Count).End(xlToLeft).Column
    For j = 2 To lc
    Cells(i, j) = Cells(i, 1) & "," & Cells(i, j)
    Next j
Next i
MsgBox "complete"






End Sub

 

[xlstarter]

Try this:

Option Explicit


Sub xlstarter()
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Dim lc As Long
Dim i As Long
Dim j As Long


For i = 1 To lr
lc = Cells(i, Columns.Count).End(xlToLeft).Column
    For j = 2 To lc
    Cells(i, j) = Cells(i, 1) & "," & Cells(i, j)
    Next j
Next i
MsgBox "complete"






End Sub

Thank you very much, works!!! You are the best!

 

[hiker95]

xlstarter,

Welcome to the MrExcel forum.

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?


The below macro will adjust for a varying number of rows, and, columns.

The screenshot of after the macro is not displaying the strikethrough in column A.

Sample raw data:

Excel 2007
	A	B	C	D
1	a	d
2	b	d
3	c	d	p
4	d	e	o
5	e	f	g	l
6	f	e	x	f
7
Sheet1

After the macro using an array in memory:

Excel 2007
	A	B	C	D
1	a	a,d
2	b	b,d
3	c	c,d	c,p
4	d	d,e	d,o
5	e	e,f	e,g	e,l
6	f	f,e	f,x	f,f
7
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 09/23/2014, ME807385
Dim a As Variant, i As Long
Dim lr As Long, lc As Long, c As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
a = Range(Cells(1, 1), Cells(lr, lc))
For i = 1 To lr
  For c = 2 To lc
    If a(i, c) <> "" Then
      a(i, c) = a(i, 1) & "," & a(i, c)
    End If
  Next c
Next i
Range(Cells(1, 1), Cells(lr, lc)) = a
Range(Cells(1, 1), Cells(lr, 1)).Font.Strikethrough = True
Columns(1).Resize(, lc).AutoFit
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.