VBA Filtering Data in Loop and Copying to Other Sheet - Handling Error#

Question

I am passing the filtering criteria in a loop to filter the data in DataSheet and select the filtered data from (Col C if user select enable) or (Col D if user select disable) and copy and paste the data to other sheet.

Filtered data may be greater than 1 row, which is why i decided to copy the data by finding the last row and writing the code as: copying the visible cells only

x = Cells(Rows.Count, "A").End(xlUp).Row
Range("C2:C" & x).SpecialCells(xlCellTypeVisible).Copy
OR
x = Cells(Rows.Count, "A").End(xlUp).Row
Range("D2:D" & x).SpecialCells(xlCellTypeVisible).Copy

this code gives me an error when filtering criteria is of First row in DataSheet where instead of selecting the single row of data its selecting the entire rows of data and throwing an error while pasting it in the other sheet.

Run-time Error '1004': We can't paste because the copy area and paste area aren't same size.

Its works fine from the second filtering criteria

Possible solution i am looking for: So instead of selecting the entire column of visible data, I am looking for another loop within For..Next Loop where it loops between visible cells only and copy data the other sheet row by row.

Below is the entire Code:

Sub CommentGen_Auto()
Dim i As Long, n As Long, x As Long, lastrow As Long
Dim wb As Workbook

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set wb = ThisWorkbook
wb.Worksheets("Filter").Select
Range("H3:H100").Clear

n = Cells(Rows.Count, "B").End(xlUp).Row

For i = 3 To n
wb.Worksheets("Filter").Select
Name = Cells(i, "B").Value
groupname = Cells(i, "C").Value
Action = Cells(i, "D").Value
class = Cells(i, "E").Value

wb.Worksheets("Data").Select
Range("A1").AutoFilter Field:=1, Criteria1:=Name
Range("A1").AutoFilter Field:=2, Criteria1:=groupname
Range("A1").AutoFilter Field:=5, Criteria1:=class

If Not IsEmpty(Action) Then
If Action = "Enable" Then
x = Cells(Rows.Count, "A").End(xlUp).Row
Range("C2:C" & x).SpecialCells(xlCellTypeVisible).Copy
Else
x = Cells(Rows.Count, "A").End(xlUp).Row
Range("D2:D" & x).SpecialCells(xlCellTypeVisible).Copy
End If

wb.Worksheets("Filter").Select
lastrow = Cells(Rows.Count, "I").End(xlUp).Row + 2
Range("I" & lastrow).PasteSpecial xlPasteAll

wb.Worksheets("Data").Select
Range("A1").AutoFilter
End If

Next
wb.Worksheets("Filter").Select
Range("A1").Select
End Sub

Error Snapshot this occurs when the filter criteria in row no. 3 is the first row of data in data sheet

Expected Results, I need Sl.no to be part of the output results.

Answer 1

Please check this link

https://www.dropbox.com/s/399lvqlz2tcnpzx/Filtering\_Automation\_v1.3-Answer2.xlsm?dl=0

Answer 2

Hi 

Please try macro as follows

******************************************************************************

Sub CommentGen_Auto()

Dim i As Long, n As Long, x As Long, Lastrow As Long

Dim WsD, WsF As Worksheet

Dim OutputData, OutputSIno, OutputComment As Range

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Set WsD = ThisWorkbook.Sheets("Data")

Set WsF = ThisWorkbook.Sheets("Filter")

WsF.Activate

Set OutputData = WsF.Range("H3:I100")

OutputData.Clear

n = Cells(Rows.Count, "B").End(xlUp).Row

For i = 3 To n

On Error Resume Next  ''' Error handling

        WsF.Activate

        SIno = Cells(i, "A").Value

        Name = Cells(i, "B").Value

        GroupName = Cells(i, "C").Value

        Action = Cells(i, "D").Value

        Class = Cells(i, "E").Value

        Lastrow = Cells(Rows.Count, "I").End(xlUp).Row + 2

        Set OutputSIno = Range("H" & Lastrow)

        Set OutputComment = Range("I" & Lastrow)

         WsD.Activate

         Range("A1").Select

         Selection.AutoFilter

        Range("A1").AutoFilter Field:=1, Criteria1:=Name

        Range("A1").AutoFilter Field:=2, Criteria1:=GroupName

        Range("A1").AutoFilter Field:=5, Criteria1:=Class

If Not IsEmpty(Action) Then

            If Action = "Enable" Then

                    x = Cells(Rows.Count, "A").End(xlUp).Row

                    Range("C2:C" & x).SpecialCells(xlCellTypeVisible).Copy

                    WsF.Activate

                    OutputComment.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

                  ''' This for loop will search on filtered cells for blank rows and highlight output cell yellow and warning text

                    For Each Cell In OutputComment.CurrentRegion

                            If IsEmpty(Cell) Then

                                    Cell.Value = Chr(34) & "No Comments Found" & Chr(34)

                                    Cell.Interior.ColorIndex = 6

                            End If

                    Next Cell

                     ''' this lines assign the serial no. as same as criteria to the output line

                    OutputSIno.Value = SIno

                    OutputSIno.Interior.ColorIndex = 15

                    OutputSIno.Font.Bold = True

            Else

                    x = Cells(Rows.Count, "A").End(xlUp).Row

                    Range("D2:D" & x).SpecialCells(xlCellTypeVisible).Copy

                    WsF.Activate

                    OutputComment.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

                     ''' This for loop will search on filtered cells for blank rows and highlight output cell yellow and warning text

                    For Each Cell In OutputComment.CurrentRegion

                            If IsEmpty(Cell) Then

                                    Cell.Value = Chr(34) & "No Comments Found" & Chr(34)

                                    Cell.Interior.ColorIndex = 6

                            End If

                    Next Cell

                    ''' this lines assign the serial no. as same as criteria to the output line

                    OutputSIno.Value = SIno

                    OutputSIno.Interior.ColorIndex = 15

                    OutputSIno.Font.Bold = True

            End If

            WsF.Activate

End If

Next i

''' Unfilter the Data table

WsD.Activate

Range("A1").Select

Selection.AutoFilter

WsF.Activate

''' To neat your Output Data

    Columns("H:I").EntireColumn.AutoFit

    Columns("H:H").HorizontalAlignment = xlCenter

Range("A1").Select

Application.DisplayAlerts = True

Application.ScreenUpdating = True

MsgBox "Done"

End Sub

***************************************************************************************

The result will look like this

Do let me know if you require any further help on this. Will be glad to help you.

If this answer would be the solution to your question, Please, share your appreciation by marking it as answered. I would be grateful to you as well.

Thanks

Regards

Jeovany CV

Answer 3

Hi 

Please try macro as follows

******************************************************************************

Sub CommentGen_Auto()

Dim i As Long, n As Long, x As Long, Lastrow As Long

Dim WsD, WsF As Worksheet

Dim OutputData, OutputSIno, OutputComment As Range

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Set WsD = ThisWorkbook.Sheets("Data")

Set WsF = ThisWorkbook.Sheets("Filter")

WsF.Activate

Set OutputData = WsF.Range("H3:I100")

OutputData.Clear

n = Cells(Rows.Count, "B").End(xlUp).Row

For i = 3 To n

On Error Resume Next  ''' Error handling

        WsF.Activate

        SIno = Cells(i, "A").Value

        Name = Cells(i, "B").Value

        GroupName = Cells(i, "C").Value

        Action = Cells(i, "D").Value

        Class = Cells(i, "E").Value

        Lastrow = Cells(Rows.Count, "I").End(xlUp).Row + 2

        Set OutputSIno = Range("H" & Lastrow)

        Set OutputComment = Range("I" & Lastrow)

         WsD.Activate

         Range("A1").Select

         Selection.AutoFilter

        Range("A1").AutoFilter Field:=1, Criteria1:=Name

        Range("A1").AutoFilter Field:=2, Criteria1:=GroupName

        Range("A1").AutoFilter Field:=5, Criteria1:=Class

If Not IsEmpty(Action) Then

            If Action = "Enable" Then

                    x = Cells(Rows.Count, "A").End(xlUp).Row

                    Range("C2:C" & x).SpecialCells(xlCellTypeVisible).Copy

                    WsF.Activate

                    OutputComment.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

                  ''' This for loop will search on filtered cells for blank rows and highlight output cell yellow and warning text

                    For Each Cell In OutputComment.CurrentRegion

                            If IsEmpty(Cell) Then

                                    Cell.Value = Chr(34) & "No Comments Found" & Chr(34)

                                    Cell.Interior.ColorIndex = 6

                            End If

                    Next Cell

                     ''' this lines assign the serial no. as same as criteria to the output line

                    OutputSIno.Value = SIno

                    OutputSIno.Interior.ColorIndex = 15

                    OutputSIno.Font.Bold = True

            Else

                    x = Cells(Rows.Count, "A").End(xlUp).Row

                    Range("D2:D" & x).SpecialCells(xlCellTypeVisible).Copy

                    WsF.Activate

                    OutputComment.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

                     ''' This for loop will search on filtered cells for blank rows and highlight output cell yellow and warning text

                    For Each Cell In OutputComment.CurrentRegion

                            If IsEmpty(Cell) Then

                                    Cell.Value = Chr(34) & "No Comments Found" & Chr(34)

                                    Cell.Interior.ColorIndex = 6

                            End If

                    Next Cell

                    ''' this lines assign the serial no. as same as criteria to the output line

                    OutputSIno.Value = SIno

                    OutputSIno.Interior.ColorIndex = 15

                    OutputSIno.Font.Bold = True

            End If

            WsF.Activate

End If

Next i

''' Unfilter the Data table

WsD.Activate

Range("A1").Select

Selection.AutoFilter

WsF.Activate

''' To neat your Output Data

    Columns("H:I").EntireColumn.AutoFit

    Columns("H:H").HorizontalAlignment = xlCenter

Range("A1").Select

Application.DisplayAlerts = True

Application.ScreenUpdating = True

MsgBox "Done"

End Sub

***************************************************************************************

The result will look like this

Do let me know if you require any further help on this. Will be glad to help you.

If this answer would be the solution to your question, Please, share your appreciation by marking it as answered. I would be grateful to you as well.

Thanks

Regards

Jeovany CV

Thanks Jeovany,

That's a beautifully written code out there, however its still throws an error.

Please refer the error screenshots.

Range("D2:D" & x).SpecialCells(xlCellTypeVisible).Copy - This method of copy pasting throws an error when the filtered data is of 2nd row. instead of selecting the entire rows in that column i am looking for another loop where it loops in the filtered data. copy cells rows by row and paste it the Filter Sheet Col H

Error No.1

Error No.2

Thanks,

Hafeez

Answer 4

Hi Jeovany,

I am able to achieve the desired outputs without any error, but i am not satisfied the way i wrote this code. can you please help here to suggest any better way here..

Sub CommentGen_Auto()

Dim i As Long, n As Long, x As Long, lastrow As Long

Dim WsD, WsF As Worksheet

Dim OutputData, OutputSlno, OutputComment As Range

Dim xName, xGroup, xAction, xClass, xSlno As String

Dim rCell As Range, rRng As Range

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Set WsD = ThisWorkbook.Sheets("Data")

Set WsF = ThisWorkbook.Sheets("Filter")

WsF.Activate

Set OutputData = WsF.Range("G3:H100")

OutputData.Clear

n = Cells(Rows.Count, "B").End(xlUp).Row

For i = 3 To n

    WsF.Activate

    xSlno = Cells(i, "A").Value

    xName = Cells(i, "B").Value

    xGroup = Cells(i, "C").Value

    xAction = Cells(i, "D").Value

    xClass = Cells(i, "E").Value

    lastrow = Cells(i, "H").End(xlUp).Row + 2

    Set OutputSlno = Range("G" & lastrow)

    Set OutputComment = Range("I" & lastrow)

    If Not IsEmpty(xAction) Then

        WsD.Activate

        Range("A1").Select

        Selection.AutoFilter

            Range("A1").AutoFilter Field:=1, Criteria1:=xName

            Range("A1").AutoFilter Field:=2, Criteria1:=xGroup

            Range("A1").AutoFilter Field:=5, Criteria1:=xClass

            If xAction = "Enable" Then

            x = Cells(Rows.Count, "A").End(xlUp).Row

                If x = 2 Then

                    Range("C2").Copy

                Else

                    Range("C2:C" & x).SpecialCells(xlCellTypeVisible).Copy

                End If

            Else

            x = Cells(Rows.Count, "A").End(xlUp).Row

                If x = 2 Then

                    Range("D2").Copy

                Else

                    Range("D2:D" & x).SpecialCells(xlCellTypeVisible).Copy

                End If

            End If

            WsF.Activate

            lastrow = Cells(Rows.Count, "H").End(xlUp).Row + 2

        If x = 1 Then

            Range("H" & lastrow) = "No Comments Found"

            Range("G" & lastrow) = xSlno

        Else

            Range("H" & lastrow).PasteSpecial xlPasteValues

            Range("G" & lastrow) = xSlno

        End If

            WsD.Activate

            Range("A1").AutoFilter

    End If

Next

      WsF.Activate

      Range("A1").Select

End Sub

Thanks,

Hafeez

Answer 5

I'm travelling now 

I'll look at it ASAIC 

But in this case 

Better share a copy of your file

On Onedrive or Dropbox and share the link 

It was difficult to reproduce you scenario 

Regards 

Jeovany