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

  • Thread starter Thread starter zrs
  • Start date Start date
Z

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
 
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
 
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
 
Back
Top