Macro for not copying Data if no data found

[RPM1979]

I have an worksheet with data. I want to put autofilter on colum "Type" with Criteria "DD", "Cash". Post autofilter i want to copy the data to new Worksheet and name it "New".

Please help me with a macro to do the above task. Please note where the data is appearing in the sheet post auto filter the same to be copied in new sheet. Incase no data meeting the criteria, then only header row to be copied in new sheet.

Please help urgently with macro

Example data is given below

State	City	Literate	Illiterate	BPL	MiddleClass	Rich	Type
Maharashtra	Mumbai	1000	800	100	850	50	Cash
Gujarat	Ahmedabad	2000	1500	250	1650	100	Cheque
Goa	Panjim	1000	900	50	940	10	Cash
Punjab	Mohali	2000	1400	50	1150	800	Cheque
Delhi	Delhi	1000	980	20	760	220	Cash
Karnataka	Bangalore	2000	1950	40	1530	430	Cheque

<colgroup><col><col><col span="3"><col><col span="2"></colgroup><tbody>
</tbody>

 

[Badeea]

Hi RPM1979,

The following code should help you and let me know if this is what you want.

Sub AutoFilterCashDD()


Dim arrAll(8, 8)

ArrayItem = 0
For i = 1 To 8
If Cells(i + 1, "H") = "Cash" Or Cells(i + 1, "H") = "DD" Then
arrAll(ArrayItem, 1) = Cells(i + 1, "A")
arrAll(ArrayItem, 2) = Cells(i + 1, "B")
arrAll(ArrayItem, 3) = Cells(i + 1, "C")
arrAll(ArrayItem, 4) = Cells(i + 1, "D")
arrAll(ArrayItem, 5) = Cells(i + 1, "E")
arrAll(ArrayItem, 6) = Cells(i + 1, "F")
arrAll(ArrayItem, 7) = Cells(i + 1, "G")
arrAll(ArrayItem, 8) = Cells(i + 1, "H")
ArrayItem = ArrayItem + 1
End If
Next i


Sheets.Add.Name = "New"

Worksheets("New").Range("A1") = Range("A1")
Worksheets("New").Range("B1") = Range("B1")
Worksheets("New").Range("C1") = Range("C1")
Worksheets("New").Range("D1") = Range("D1")
Worksheets("New").Range("E1") = Range("E1")
Worksheets("New").Range("F1") = Range("F1")
Worksheets("New").Range("G1") = Range("G1")
Worksheets("New").Range("H1") = Range("H1")

For j = 1 To 8
Worksheets("New").Cells(j + 1, "A") = arrAll(j - 1, 1)
Worksheets("New").Cells(j + 1, "B") = arrAll(j - 1, 2)
Worksheets("New").Cells(j + 1, "C") = arrAll(j - 1, 3)
Worksheets("New").Cells(j + 1, "D") = arrAll(j - 1, 4)
Worksheets("New").Cells(j + 1, "E") = arrAll(j - 1, 5)
Worksheets("New").Cells(j + 1, "F") = arrAll(j - 1, 6)
Worksheets("New").Cells(j + 1, "G") = arrAll(j - 1, 7)
Worksheets("New").Cells(j + 1, "H") = arrAll(j - 1, 8)
Next j

End Sub

 

[RPM1979]

Hi,

Thanks for assistance. I would like to inform you that my data range is quite large and same is variable i.e. sometimes 2000 rows, some time 200000.

I need a macro which will help me in all scenarios. Please suggest macro for same since i am new to VBA coding and macros.

 

[Badeea]

What about the columns? Are they fixed (8)?

 

[RPM1979]

Hi,

Yes there would be 8 columns. No change in order of columns also.

 

[RPM1979]

Hi

I am using below VBA code. The problem is even there is data post filter only header row is copied in new sheet.

Basically i want below 2:

Post filter if there is data, then entire data alongwith Header to be copied in new Sheet.
Post filter if there is no data meeting the criteria, only the Header row to be copied in new sheet.

Dim myRange
ActiveSheet.Range("$A:$T").AutoFilter Field:=20, Criteria1:="<>"
ActiveSheet.Range("$A:$AW").AutoFilter Field:=10, Criteria1:=Array( _
"CHQ RETURN", "INWARD CLEARING ", _
"OUTWARD CLEARING", "CLRG&OTHERS")
Set myRange = Range(Range("J2"), Range("J" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
If myRange.Row = 1 Then
myRange.EntireRow.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Sheets("Sheet7").Select
Sheets("Sheet7").Name = "New Data"

Else
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Sheets("Sheet7").Select
Sheets("Sheet7").Name = "New Data"

End If

Please assist in modification of above VBA code to get me my data

 

[RPM1979]

Hi,

Any friends please assist me with a solution on above.