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

keithdb69

New Member
Joined
Jun 25, 2015
Messages
3
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
 
Last edited:

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Osvaldo Palmeiro

Well-known Member
Joined
Feb 24, 2009
Messages
635
Office Version
  1. 365
Platform
  1. Windows
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.

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("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

New Member
Joined
Jun 25, 2015
Messages
3
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.

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("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

New Member
Joined
Jun 25, 2015
Messages
3
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!!
 

Watch MrExcel Video

Forum statistics

Threads
1,130,042
Messages
5,639,730
Members
417,108
Latest member
Thein Than

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top