sindhuja
07-26-2012, 05:20 AM
Hi All,
I have used the array for the values which i need to filter. They are "Reason - A", "Type - B"
my requirement is first i need check for both the values in column 42 and if found copy paste into sheet DTA.
Then check again in the column 43 for the same criteria and copy paste the values to DTA sheet provided no duplicates found in DTA sheet.
I have tried with the below code but the results are not as expected.
myArr = Array("Reason - A", "Type - B")
Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))
WSNew.Name = "DTA"
Worksheets("DTA Details").Activate
For i = LBound(myArr) To UBound(myArr)
With ActiveSheet
.AutoFilterMode = False
.Range("A1:BZ" & .Rows.Count).AutoFilter Field:=42, Criteria1:=myArr(i)
Set rng = Nothing
With .AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
CCount = 0
On Error Resume Next
CCount = rng.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas:" _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Copy to worksheet"
Else
Worksheets("DTA Details").Activate
rng.Parent.AutoFilter.Range.Copy
lastrw = Sheets("DTA").Range("a" & Rows.Count).End(xlUp).Row
MsgBox lastrw
With Sheets("DTA Details").Range("A2:BX" & lastrw)
.Copy
Worksheets("DTA").Cells(Rows.Count, 1).End(xlUp).Offset(lastrw, 0).PasteSpecial xlPasteValues
End With
Application.DisplayAlerts = True
End If
End If
End With
End With
Worksheets("DTA Details").Activate
Next i
Kindly help me out in completing my task by edidting the above code.
-Sindhuja
I have used the array for the values which i need to filter. They are "Reason - A", "Type - B"
my requirement is first i need check for both the values in column 42 and if found copy paste into sheet DTA.
Then check again in the column 43 for the same criteria and copy paste the values to DTA sheet provided no duplicates found in DTA sheet.
I have tried with the below code but the results are not as expected.
myArr = Array("Reason - A", "Type - B")
Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))
WSNew.Name = "DTA"
Worksheets("DTA Details").Activate
For i = LBound(myArr) To UBound(myArr)
With ActiveSheet
.AutoFilterMode = False
.Range("A1:BZ" & .Rows.Count).AutoFilter Field:=42, Criteria1:=myArr(i)
Set rng = Nothing
With .AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
CCount = 0
On Error Resume Next
CCount = rng.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas:" _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Copy to worksheet"
Else
Worksheets("DTA Details").Activate
rng.Parent.AutoFilter.Range.Copy
lastrw = Sheets("DTA").Range("a" & Rows.Count).End(xlUp).Row
MsgBox lastrw
With Sheets("DTA Details").Range("A2:BX" & lastrw)
.Copy
Worksheets("DTA").Cells(Rows.Count, 1).End(xlUp).Offset(lastrw, 0).PasteSpecial xlPasteValues
End With
Application.DisplayAlerts = True
End If
End If
End With
End With
Worksheets("DTA Details").Activate
Next i
Kindly help me out in completing my task by edidting the above code.
-Sindhuja