I am sending the file back the new name is
moving_to_rows salvdali.xls
1 YOU ARE MESSING UP WITH DATA. SO SAVE THE FILE SOEMWHERE SAFELY FOR EASY RETIEVAL
2.i HAVE INSERTED A NEW SHEET IN THIS FILE AND CALLED IT "sheet3"
3.I COPIED THE DATA IN SHEET ("data I have") TO sheet3 for retrieval if necessary
4. THE MACROS ARE IN VB EDITOR MODULE 1
In the file I have sent the sheet 1 is after I have run the mcro "test'
for rechecking
1.RUN undo
2.check whether the old data is copied to first sheet
3.run test
CONFIRM WHETHER YOU GOT WHAT YOU WANT.
for compeltion sake I am copying the the macros below
Dim j As Long, r As Range, r1() As Range
Dim c As Range, k As Long, m As Long, n As Long
Dim r2 As Range
Sub test()
Worksheets("data I have").Activate
'IF NECESSARY CHANGE THE NAME OF THE SHEET.
Set r = Range(Range("A1"), Cells(Rows.Count, "A").End(xlUp))
j = WorksheetFunction.CountA(r)
ReDim r1(1 To j)
k = 1
For Each c In r
If c <> "" Then
Set r1(k) = c
'msgbox r1(k)
k = k + 1
End If
Next c
For k = 1 To j
If k = j Then
n = Cells(r1(k).Row, "c").End(xlDown).Row - r1(k).Row
'msgbox n
n = n + 1
GoTo mloop
End If
n = r1(k + 1).Row - r1(k).Row
'msgbox n
mloop:
For m = 1 To n - 1
Set r2 = r1(k).Offset(m, 0).End(xlToRight)
Set r2 = Range(r2, r2.End(xlToRight))
'msgbox r2.Address
r2.Cut r1(k).End(xlToRight).Offset(0, 1)
Next m
Next k
r.Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sub undo()
Worksheets("data I have").Activate
'IF NECESSARY CHANGE THE NAME OF THE SHEET.
Cells.Clear
Worksheets("sheet3").UsedRange.Copy Range("A1")
End Sub
Bookmarks