VBA Copy& Paste Based on Single Criteria

[mdonovan890]

Hello,
Below is the code that I am currently using to copy all the rows on each of the specified worksheets based upon a single criteria (Column N="Y"). The Marco then pastes these rows as values on Sheet 4. This code functions properly however, it is extremely slow. The verison of Excel that I working in is 32 BIT Excel 2016.I am hoping to get some suggestions on how to make this VBA run more efficiently. Many thanks!



Public Sub COPYOUSDATA()


Dim ws As Worksheet
Dim destinationWorksheet As Worksheet
Dim columnN As Range
Dim c As Range
Dim count As Long

Set destinationWorksheet = ActiveWorkbook.Worksheets("Sheet4")

destinationWorksheet.Cells.ClearContents

count = 1
For Each ws In ActiveWorkbook.Worksheets

If ws.Name = "{OUS Region A} Europe" Or ws.Name = "{OUS Region B} Asia-Pacific" Or ws.Name = "{OUS Region C} Latin America"

Set columnN = ws.Range("N:N") 'columnN
For Each c In columnN
If WorksheetFunction.IsText(c.Value) Then
If InStr(c.Value, "Y") > 0 Then
c.EntireRow.Copy
destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats
count = count + 1
End If
End If
Next c

End If

Next ws


End Sub

 

[Fluff]

How about

Public Sub COPYOUSDATA()
Dim ws As Worksheet
Dim destinationWorksheet As Worksheet
Dim count As Long

Set destinationWorksheet = ActiveWorkbook.Worksheets("Sheet4")

destinationWorksheet.Cells.ClearContents

count = 1
For Each ws In ActiveWorkbook.Worksheets
   If ws.Name = "{OUS Region A} Europe" Or ws.Name = "{OUS Region B} Asia-Pacific" Or ws.Name = "{OUS Region C} Latin America" Then
      If Application.CountIf(ws.Range("N:N"), "Y") > 0 Then
         ws.Range("N:N").AutoFilter 1, "Y"
         ws.AutoFilter.Range.Offset(1).Copy
         destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats
         count = destinationWorksheet.Cells(Rows.count, 1).End(xlUp).Offset(1).Row
      End If
   End If
Next ws
End Sub

 

[mdonovan890]

Hello,
This code is only copying the information in column N, i would need all the data for from each row. Also after running, the tabs are showing as filtered and each one needs to be cleared out before new data can be entered. Is there a way to improve this code while still copying the entire row and automatically clearing out the any filtering that was done with the VBA? Thanks for your help.

 

[Fluff]

Try

Public Sub COPYOUSDATA()
Dim ws As Worksheet
Dim destinationWorksheet As Worksheet
Dim count As Long

Set destinationWorksheet = ActiveWorkbook.Worksheets("Sheet4")

destinationWorksheet.Cells.ClearContents

count = 1
For Each ws In ActiveWorkbook.Worksheets
   If ws.Name = "{OUS Region A} Europe" Or ws.Name = "{OUS Region B} Asia-Pacific" Or ws.Name = "{OUS Region C} Latin America" Then
      If Application.CountIf(ws.Range("N:N"), "Y") > 0 Then
         ws.Range("N:N").AutoFilter 1, "Y"
         ws.AutoFilter.Range.Offset(1).EntireRow.Copy
         destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats
         count = destinationWorksheet.Cells(Rows.count, 1).End(xlUp).Offset(1).Row
         ws.AutoFilterMode = False
      End If
   End If
Next ws
End Sub