Copy rows from one workbook to another workbook if certain criteria is met

[keithdb69]

My setup: (2 Workbooks) Workbook 1 "Line Audit Workbook", Workbook 2 "Data"
Workbook 1 has 2 worksheets - "1st Shift" and "2nd Shift"
Workbook 2 has 1 worksheet - "Data".
In workbook 1, both worksheets are set up identically with 13 columns. Each shift (1st Shift and 2nd Shift) gets information added on a daily basis by an employee from that particular shift.
Workbook 2 is set up exactly like workbook 1 except it only has 1 worksheet.

What I want to Accomplish: When the rows are filled out (from either worksheet in workbook 1) and the text "NOT OK" is typed into column "H", I want the entire row (A:M) copied and paste into the "Data" workbook. I do not want any formatting pasted,just numbers and text only.

What I have searched and found: I have searched this question and the closest thing I could find is the code I pasted below. This code will do what I want, but it copies to a "data" worksheet in the same workbook and it also copies the formatting over as well. I need this to copy into a different workbook so people can view the information without having to sort through all of the data but just be able to see the non conformances as well as keep them out of our main workbook. Our workbook 1 at work has thousands of rows so the dropbox link below is just an example.

I appreciate any help someone can give me. This is my first post so I'm still trying to figure out everything. If more information is needed, please let me know and I'll try and provide. We are using Microsoft Excel 2010.

Option ExplicitSub GetYes()


Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Sheets("Data")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 1 Then wM.Range("A2:L" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Data" Then
y = 0
On Error Resume Next
y = Application.CountIf(ws.Columns(8), "NOT OK")
On Error GoTo 0
If y > 1 Then
firstaddress = ""
With ws.Columns(8)
Set c = .Find("NOT OK", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
nr = wM.Range("H" & Rows.Count).End(xlUp).Offset(1).Row
ws.Range("A" & c.Row & ":L" & c.Row).Copy wM.Range("A" & nr)
Application.CutCopyMode = False
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub

I will try and leave a dropbox link so you can view the workbooks:
https://www.dropbox.com/s/ianakcasimym5eo/Data.xlsx?dl=0
https://www.dropbox.com/s/8gr7gfi59gggzgu/Line Audit Workbook.xlsx?dl=0

 

[Osvaldo Palmeiro]

Hi Keith.
See if the code below is what you're looking for.
Before running it I think you could exclude the sheet named 'Sheet3' from 'Line Audit' workbook and you should create a sheet named 'Data' on 'Data' workbook.

Sub GetYes()
 Dim wM As Worksheet, ws As Worksheet
 Dim r As Long, lr As Long, nr As Long, y As Long
 Dim c As Range, firstaddress As String
  Application.ScreenUpdating = False
   Set wM = Workbooks("Cópia de Data").Sheets("Data")
    lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
     If lr > 2 Then wM.Range("A3:L" & lr).ClearContents
      For Each ws In ThisWorkbook.Worksheets
       On Error Resume Next
       y = Application.CountIf(ws.Columns(8), "NOT OK")
       On Error GoTo 0
        If y > 1 Then
         firstaddress = ""
          With ws.Columns(8)
           Set c = .Find("NOT OK", LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
             firstaddress = c.Address
              Do
               nr = wM.Range("H" & Rows.Count).End(xlUp).Offset(1).Row
               wM.Range("A" & nr).Resize(, 13).Value = ws.Range("A" & c.Row & ":M" & c.Row).Value
               Set c = .FindNext(c)
              Loop While Not c Is Nothing And c.Address <> firstaddress
            End If
          End With
        End If
      Next ws
   wM.Activate
  Application.ScreenUpdating = True
End Sub

 

[keithdb69]

Hi Keith.
See if the code below is what you're looking for.
Before running it I think you could exclude the sheet named 'Sheet3' from 'Line Audit' workbook and you should create a sheet named 'Data' on 'Data' workbook.

Sub GetYes()
 Dim wM As Worksheet, ws As Worksheet
 Dim r As Long, lr As Long, nr As Long, y As Long
 Dim c As Range, firstaddress As String
  Application.ScreenUpdating = False
   Set wM = Workbooks("Cópia de Data").Sheets("Data")
    lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
     If lr > 2 Then wM.Range("A3:L" & lr).ClearContents
      For Each ws In ThisWorkbook.Worksheets
       On Error Resume Next
       y = Application.CountIf(ws.Columns(8), "NOT OK")
       On Error GoTo 0
        If y > 1 Then
         firstaddress = ""
          With ws.Columns(8)
           Set c = .Find("NOT OK", LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
             firstaddress = c.Address
              Do
               nr = wM.Range("H" & Rows.Count).End(xlUp).Offset(1).Row
               wM.Range("A" & nr).Resize(, 13).Value = ws.Range("A" & c.Row & ":M" & c.Row).Value
               Set c = .FindNext(c)
              Loop While Not c Is Nothing And c.Address <> firstaddress
            End If
          End With
        End If
      Next ws
   wM.Activate
  Application.ScreenUpdating = True
End Sub

Thank you for your quick response Osvaldo, here is what happened after running the macro: The text in orange was highlighted yellow. I did rename the worksheet to "Data" and deleted the "sheet 3" before running it. Thank you,

Sub GetYes()
Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Workbooks("Cópia de Data").Sheets("Data")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 2 Then wM.Range("A3:L" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
On Error Resume Next
y = Application.CountIf(ws.Columns(8), "NOT OK")
On Error GoTo 0
If y > 1 Then
firstaddress = ""
With ws.Columns(8)
Set c = .Find("NOT OK", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
nr = wM.Range("H" & Rows.Count).End(xlUp).Offset(1).Row
wM.Range("A" & nr).Resize(, 13).Value = ws.Range("A" & c.Row & ":M" & c.Row).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub

 

[keithdb69]

I think I have it now Osvaldo, here is the final code:

Sub GetYes()
Dim wM As Worksheet, ws As Worksheet
Dim r As Long, lr As Long, nr As Long, y As Long
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set wM = Workbooks("Data").Sheets("Data")
lr = wM.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
If lr > 2 Then wM.Range("A3:L" & lr).ClearContents
For Each ws In ThisWorkbook.Worksheets
On Error Resume Next
y = Application.CountIf(ws.Columns(8), "NOT OK")
On Error GoTo 0
If y > 1 Then
firstaddress = ""
With ws.Columns(8)
Set c = .Find("NOT OK", LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
nr = wM.Range("H" & Rows.Count).End(xlUp).Offset(1).Row
wM.Range("A" & nr).Resize(, 13).Value = ws.Range("A" & c.Row & ":M" & c.Row).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
End If
Next ws
wM.Activate
Application.ScreenUpdating = True
End Sub

Thank you so much for your help!!