Arrange (Cut and Insert Cut Cells) Rows using VBA Code

[marathon123]

Hi All,

I'm a beginner and have very less knowledge on VBA.

There are 2 worksheets in the attachment - 'Sheet 1 and Sheet 2'.

Once I run the Code on 'Sheet 1' I would like to see Data as on 'Sheet 2'.

Basically, I thought to write a lot of stuff here and ended up writing a lot and had everything deleted.

My thanks in advance to all the experts.. I using Excel 2007

Thank you...

[CatDaddy]

Sub Macro1()
Dim cell As Range
Dim r, lr As Long
With ActiveWorkbook.Worksheets(1)
lr = .Range("A" & Rows.Count).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With .Sort
.SetRange Range("A2:D" & lr)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

For r = lr To 3 Step -1

If .Range("A" & r).Value <> .Range("A" & r - 1).Value Then
Rows(r & ":" & r).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next r
End With
End Sub

[marathon123]

Hi Cat Daddy,

I'm really happy to see your quick response. I appreciate and thank you a lot.

However, the Code is about sorting the Rows. I would want the Rows to be in Order as d1, c1, a1, e1 and f1 not as a1, c1, d1, e1 and f1.

Could you please help?

Thank you.

[marathon123]

Hi Cat Daddy,

I'm really happy to see your quick response. I appreciate and thank you a lot.

However, the Code is about sorting the Rows. I would want the Rows to be in Order as d1, c1, a1, e1 and f1 not as a1, c1, d1, e1 and f1.

Could you please help?

Thank you.

[CatDaddy]

ya no problem give me 5 minutes

[CatDaddy]

Sub alexRules()
Dim lr, r As Long
With Sheets(1)
lr = .Range("A" & Rows.Count).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, CustomOrder:="d1,c1,a1,e1,f1", DataOption:=xlSortNormal
With .Sort
.SetRange Range("A2:D" & lr)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

For r = lr To 3 Step -1
If .Range("A" & r).Value <> .Range("A" & r - 1).Value Then .Rows(r & ":" & r).Insert Shift:=xlDown
Next r
End With
End Sub