.
Here is one meethod :
Option Explicit
Sub Stage1()
Dim c As Range
Dim r As Integer
Dim LastRow As Long
Dim Cells As Range
Sheets("Sheet2").UsedRange.Value = ""
With Sheet1
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
LastRow = LastRow - 1
For Each c In Range("D:D")
If Not IsEmpty(c) Then
r = r + 1
Sheet2.Cells(r, 1) = .Cells(c.Row, 1)
Sheet2.Cells(r, 2) = .Cells(c.Row, 2)
Sheet2.Cells(r, 3) = .Cells(c.Row, 3)
Sheet2.Cells(r, 4) = .Cells(c.Row, 4)
'Sheet2.Cells(r, 5) = Cells(c.Row, 9)
End If
Next c
End With
End Sub
Sub Stage2()
Dim c As Range
Dim r As Integer
Dim LastRow As Long
Dim Cells As Range
Sheets("Sheet3").UsedRange.Value = ""
With Sheet1
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
LastRow = LastRow - 1
For Each c In Range("E:E")
If Not IsEmpty(c) Then
r = r + 1
Sheet3.Cells(r, 1) = .Cells(c.Row, 1)
Sheet3.Cells(r, 2) = .Cells(c.Row, 2)
Sheet3.Cells(r, 3) = .Cells(c.Row, 3)
Sheet3.Cells(r, 4) = .Cells(c.Row, 5)
'Sheet2.Cells(r, 5) = Cells(c.Row, 9)
End If
Next c
End With
End Sub
Bookmarks