Excel macro concatenate each 2 rows data into 1 row for all sheet

[zrs]

Hi all,

I have an excel sheet of 12000 rows of datas and I need to concetenate
the datas in each 2 rows into 1 row with fixed size and delete the
previous ones if possible or to create a new sheet with the
concatenated datas to the same workbook.

Eg:

Before
A B C D E ...
1 Data1 Data2 Data3 Data4 Data5
2 Data6 Data7 Data8 Data9 Data10
3 Data11 Data12 Data13 Data14 Data15
4 Data16 Data17 Data18 Data19 Data20
5 Data21 Data22 Data23 Data24 Data25
6 Data26 Data27 Data28 Data29 Data30

After
A B C D E F
G H I J
1 Data1 Data2 Data3 Data4 Data5 Data6 Data7
Data8 Data9 Data10 (Row 1 & 2 concatenated)
2 Data11 Data12 Data13 Data14 Data15 Data16 Data17 Data18
Data19 Data20 (Row 3 & 4 concatenated)
3 Data21 Data22 Data23 Data24 Data25 Data26 Data27 Data28
Data29 Data30 (Row 5 & 6 concatenated)

Hope a macro can select each 2 rows to concatenate one by one and can
work for whole sheet.

Any ideas would be greatly appreciated. Thanks...

Reha

 

[Socko]

Please use the following macro for the desired task
Sub CombineTwoRows()
'For more examples please visit http://socko.wordpress.com
'Selva V Pasupathy, Hyderabad
Dim i, j As Integer
Dim newSheet, oldSheet As Worksheet

'Create a new sheet to show the combined row data
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "CombinedRow"

'Set a reference to the sheet with existing data
Set oldSheet = ThisWorkbook.Sheets("sheet1")

j = 1
For i = 1 To 6000
newSheet.Activate
newSheet.Cells(i, 1).Activate

oldSheet.Range(oldSheet.Cells(j, 1), oldSheet.Cells(j, 5)).Copy
newSheet.Cells(i, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
j = j + 1

oldSheet.Range(oldSheet.Cells(j, 1), oldSheet.Cells(j, 5)).Copy
newSheet.Cells(i, 6).Select
ActiveSheet.Paste
Application.CutCopyMode = False
j = j + 1
Next i
End Sub

Download an example workbook http://www.sockofiles.350.com/combine2row.xls

I hope this helps

Selva V Pasupathy
For more on Excel, VBA, & other resources
Please visit http://socko.wordpress.com

 

[Don Guillett]

This should do
Sub mergerowsanddeleteold()
mc = 1 '"a"
For i = 2 To Cells(Rows.Count, mc).End(xlUp).Row Step 2
Cells(i, mc).Resize(, 5).Cut Cells(i - 1, mc + 5)
Next i
Columns(mc).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
columns.autofit
End Sub