Microsoft Excel - Copy with Macro Including header if one of the column contains X

Asked By John on 09-Nov-12 10:11 AM
I have an excel sheet which as given below. A1 to A6 are header. Near about 600 rows contains the sheet. I would like to copy if column I, after A6 contains X should copy to sheet 2. Header also copy to sheet 2. Can it possible with Macro. I could not attach zip file here. Excel sheet as below.


 

M/S

 

 

 

 

 

 

 

 

M/S

 

 

 

 

 

 

 

 

CLEARING

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

S.N.

NAME OF ITEMS

MRP

PACKING SIZE

DISCOUNT (%)

VAT RATES (%)

ORDER QTY IN PCS

ORDER QTY IN BOXES

copy

1

AAMLKI RASAYAN -100GM

65

200

20.63

5

 

 

 

2

AAMVATARI RAS-20GM

35

400

20.63

5

 

 

 

3

AAROGYA DALIA (PUSHTAHAR) -500GM

30

30

20.63

5

 

 

 

4

AAROGYA VARDHANI VATI 20GM

40

400

20.63

5

 

 

 

5

AAROGYA VARDHANI VATI 40GM

80

400

20.63

5

 

 

 

6

ABHAYARISHTA-450ML

60

20

20.63

5

 

 

 

7

ABHRAK BHASM -5GM

13

200

20.63

5

 

 

 

8

AJMODADI CHURN-100 GRM

30

100

20.63

5

 

 

 

9

AKIK PISHTI - 5GM

15

200

20.63

5

 

 

 

10

AMLA CANDY 500 GRM

110

24

20.63

5

 

 

 

11

AMLA CHATPATA -500GM

115

24

20.63

5

 

 

 

12

AMLA CHURNA -100GM

20

100

20.63

5

1000

 

 

John D replied to John on 10-Nov-12 11:20 AM
HI
Try this if column i as x

Sub TransferX()
Dim sh2 As Worksheet
Dim i As Double
Dim lastrow As Double

Set sh2 = Sheets("Sheet2")
lastrow = Cells(Rows.Count, 9).End(xlUp).Row
For i = 6 To lastrow
If Cells(i, 9).Value = "x" Then
lastrow = sh2.Cells(Cells.Rows.Count, 1).End(xlUp).Row
Rows(1).Resize(6).EntireRow.Copy Destination:=sh2.Rows(1)
Rows(i).EntireRow.Copy Destination:=sh2.Cells(lastrow + 1, 1)
End If
Next i
End Sub

John D replied to John on 10-Nov-12 07:38 PM
Hi
Use this one:
Option Explicit
Sub TransferX()
 Dim sh2 As Worksheet
 Dim i As Double
 Dim lastrow As Double
 Set sh2 = Sheets("Sheet2")
 lastrow = Cells(Rows.Count, 9).End(xlUp).Row
 For i = 7 To lastrow
 If Cells(i, 9).Value = "x" Then
 Rows(1).Resize(6).EntireRow.Copy Destination:=sh2.Rows(1)
 lastrow = sh2.Cells(Cells.Rows.Count, 1).End(xlUp).Row
 Rows(i).EntireRow.Copy Destination:=sh2.Cells(lastrow + 1, 1)
 End If
 Next i
 End Sub