Copying transactions pairs to the next row

[TurkisH]

Hiya peeps,

I need to copy transaction pairs to the next row. A particular ro
looks like this:


Code
-------------------

1863 1864 1865 1866 1867 1868 1869

2000 3000 1805 100
-------------------

So now I need to take first to take the first transaction pair in thi
case 2000 and 3000 and put them into the next row, like this:

Code
-------------------

1863 1864 1865 1866 1867 1868 1869

2000 3000

-------------------

After that I need to put the next transaction pair 3000 and 1805 to th
row after that one, like this:

Code
-------------------

1863 1864 1865 1866 1867 1868 1869

3000 1805

-------------------

And so on, furthermore the new rows with the transactions pairs shoul
be inserted since there are more rows with data which need the sam
formulas. Can anyone help me with this problem, I would be ver
grateful, I have trouble, because I don't know how to check how to ski
the null values and find the correct transaction pair (so first th
first one, then second etc).

Kind regards,

Turkis

 

[jeff]

Hi, Turkish,

Try this macro on a TEST copy of your data sheet.
(it leaves row 1 alone)

jeff

Sub MakePairs()
Dim lastrow As Long
Dim numColumns As Long
Dim StartCol As Integer
Dim CopyOne, CopyTwo As Variant
LastInsertRow = 0
Application.ScreenUpdating = False

ActiveCell.SpecialCells(xlLastCell).Select
lastrow = ActiveCell.Row

numColumns = ActiveSheet.Range("A1").End(xlToRight).Column
For row_index = lastrow To 2 Step -1
For cols = 1 To numColumns
CopyOne = ""
CopyTwo = ""
If Cells(row_index, cols).Value <> "" Then
CopyOne = Cells(row_index, cols).Value
For cols2 = cols + 1 To numColumns
If Cells(row_index, cols2).Value <> "" Then
CopyTwo = Cells(row_index, cols2).Value
Exit For
End If
Next cols2
End If
If CopyOne <> "" And CopyTwo <> "" Then
If LastInsertRow = 0 Then LastInsertRow =
row_index + 1
Range(Cells(LastInsertRow, 1), Cells
(LastInsertRow, 1)).Select
Selection.EntireRow.Insert shift:=xlShiftDown
Range(Cells(LastInsertRow, cols), Cells
(LastInsertRow, cols)).Value = CopyOne
Range(Cells(LastInsertRow, cols2), Cells
(LastInsertRow, cols2)).Value = CopyTwo
LastInsertRow = Selection.Row + 1
End If
Next cols
'Rows(row_index).Delete 'uncomment this line to
delete original data row
LastInsertRow = 0
Next row_index

Application.ScreenUpdating = True
End Sub