if find the matched data in another workbook copy the complete row

I have a workbook with one sheet (sheet1) with column A and also i have another workbook with name SourcePart.


The below VBA code will be check the items on column A on sheet 1 and if find the same on workbook SourcePart will copy data to sheet 1 on column B and c ... .


Now my problem is Example :


Sheet1 :
A1: Book


Workbook SourcePart
Sheet1:
E300: Book


it will copy the data after E300 that mean it will not copy from A300 , i need if find data on each column copy the complete row , not after found matched data .


Hope you will understand .



The range that will check is from column A to column P on workbook SourcePart

Code:

---

Sub WNChecker()
   
    Dim i As Long
    Dim Parts As Worksheet
    Dim SourcePart As Worksheet
    Dim F_Rng As Range
    Dim T_Str As String
    Dim L_Rw As Long
   
    Set Parts = ThisWorkbook.Sheets("Sheet1")
   
    With Parts
        L_Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To L_Rw
            T_Str = .Cells(i, 1).Value
            For Each SourcePart In Workbooks("SourcePart").Sheets
               
                With SourcePart
                   
                    Set F_Rng = .Range("A:P").Find(T_Str, , , xlWhole)
                    If Not F_Rng Is Nothing Then
                        F_Rng.Offset(, 1).Resize(, 20).Copy Parts.Cells(i, 2)
                        Exit For
                    End If
                End With
            Next
        Next i
    End With
   
    Set F_Rng = Nothing
    Set SourcePart = Nothing
    Set Parts = Nothing
   
End Sub

---

I changed my code from

Code:

---

  Set F_Rng = .Range("A:P").Find(T_Str, , , xlWhole)
                    If Not F_Rng Is Nothing Then
                        F_Rng.Offset(, 1).Resize(, 20).Copy Parts.Cells(i, 2)
                      Exit For

---

to

Code:

---

Set F_Rng = .Range("A:P").Cells.Find(T_Str, , , xlWhole)
                If Not F_Rng Is Nothing Then
                    F_Rng.Cells.Offset(, 1).EntireRow.Resize(, 2).Copy Parts.Cells(i, 1)
                    Exit For

---

and it is work , but there is a problem , that's in workbook SourcePart, all A1 row in all sheets must be empty .

I added a Sample a Zip file with 2 files, First must open SourcePart.xlsx after that open Check-SourcePart.xlsm when CTRL + F5 you will see the problem but if add a blank row on A1 it will be work.

Please help me on this subject it is about 4 days i am try to find a solution but i cannot.

as a default, find will start after A1, so you need to define the after for find
the best, is after the last cell used then the first found can be A1

try like

Code:

---

Set F_Rng = .Range("A:P").Find(T_Str,.usedrange.cells(.usedrange.cells.count) , , xlWhole)

---

it is not work the same result , fi you check the attachment on post #2 you can see the result .

Please help me :(

Can you post a sheet showing what you expected to be imported?

Please download the zip file and open both of excel files and one time run it and you will see the problem and again open the files and add a blank row on SourcePart.xlsx that mean A1 will be blank and run the VBA you will see the result and i need it .


Please do not use this excel file , just want to show the result for check you can use the sample on zip file that i added in post #2

Please check the enclosed excel files , there is 3 sheet ,

Sheet - Original that mean the first data - (the data will search on SourcePart)
Sheet1 : VBA does not work correctly : if you see blank fields repeated the first row of SourcePart file
Sheet2: VBA work : because i added a blank row on SourcePart that mean A1 row is blank .

Thank you for your help and kind .

Use IsEmpty():

Code:

---

Sub SourcePart()
    Dim i As Long
    Dim Parts As Worksheet
    Dim SourcePart As Worksheet
    Dim F_Rng As Range
    Dim T_Str As String
    Dim L_Rw As Long
   
    Set Parts = ThisWorkbook.Sheets("Sheet1")
   
    With Parts
        L_Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To L_Rw
            T_Str = .Cells(i, 1).Value
            For Each SourcePart In Workbooks("SourcePart.xlsx").Sheets
                With SourcePart
                  Set F_Rng = .Range("A:P").Cells.Find(T_Str, , , xlWhole)
                  If Not F_Rng Is Nothing And Not IsEmpty(F_Rng) Then
                    F_Rng.Cells.Offset(, 1).EntireRow.Resize(, 5).Copy Parts.Cells(i, 1)
                    Exit For
                  End If
                End With
            Next SourcePart
        Next i
    End With
End Sub

---

Really you are talent and you fixed my problem .

Thank you Kenneth Hobs

now just there is a problem if I have more than one row the it will find it will Copy only the first that founded now I need to copy all row that find and paste in one row

I don't have time to test this right now. It should go something like:

Code:

---

Sub SourcePart()    Dim i As Long
    Dim Parts As Worksheet
    Dim SourcePart As Worksheet
    Dim F_Rng As Range
    Dim T_Str As String
    Dim L_Rw As Long
    Dim c As Range
   
    Set Parts = ThisWorkbook.Sheets("Sheet1")
   
    With Parts
        L_Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To L_Rw
            T_Str = .Cells(i, 1).Value
            For Each SourcePart In Workbooks("SourcePart.xlsx").Sheets
                With SourcePart
                    Set F_Rng = FindAll(.Range("A:P").Cells, T_Str, , xlWhole)
                    For Each c In F_Rng
                      If Not F_Rng Is Nothing And Not IsEmpty(F_Rng) Then
                          F_Rng.Cells.Offset(, 1).EntireRow.Resize(, 5).Copy Parts.Cells(i, 1)
                          Exit For
                      End If
                    Next c
                End With
            Next SourcePart
        Next i
    End With
End Sub


' http://www.cpearson.com/Excel/FindAll.aspx
Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
              Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean




CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
    XLookAt = xlPart
Else
    XLookAt = LookAt
End If


' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.


For Each Area In SearchRange.Areas
    With Area
        If .Cells(.Cells.Count).Row > MaxRow Then
            MaxRow = .Cells(.Cells.Count).Row
        End If
        If .Cells(.Cells.Count).Column > MaxCol Then
            MaxCol = .Cells(.Cells.Count).Column
        End If
    End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)


On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
        after:=LastCell, _
        LookIn:=LookIn, _
        LookAt:=XLookAt, _
        SearchOrder:=SearchOrder, _
        MatchCase:=MatchCase)


If Not FoundCell Is Nothing Then
    Set FirstFound = FoundCell
    Do Until False ' Loop forever. We'll "Exit Do" when necessary.
        Include = False
        If BeginsWith = vbNullString And EndsWith = vbNullString Then
            Include = True
        Else
            If BeginsWith <> vbNullString Then
                If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
            If EndsWith <> vbNullString Then
                If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
        End If
        If Include = True Then
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
        End If
        Set FoundCell = SearchRange.FindNext(after:=FoundCell)
        If (FoundCell Is Nothing) Then
            Exit Do
        End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
        End If


    Loop
End If
   
Set FindAll = ResultRange


End Function

---

Dear Kenneth Hobs

Thank you very much but when run the VBA show me this error

Run-time error '1004'
Application-defined or object-defined error

Code:

---

F_Rng.Cells.Offset(, 1).EntireRow.Resize(, 5).Copy Parts.Cells(i, 2)

---

Thank you again

Code:

---

c.Cells.Offset(, 1).EntireRow.Resize(, 5).Copy Parts.Cells(i, 1)

---

Thank you again but another error appear :

Run-time error '424': Object required

Code:

---

For Each c In F_Rng

---

I added the sample files.

The result must be these data in one row

http://i57.tinypic.com/34zx3xf.png

Thank you

Obviously, the FindAll() did not find anything. You will need to check that after the Set by:

Code:

---

Set F_Rng = .Range("A:P").Find(T_Str, , , xlWhole)
If F_Rng is Nothing then
  MsgBox "Not Found"
  Exit Sub
End If

---

Thank you i paste the above code on my VBA but the result is only the first item that it will find . it will not copy the others, :(

Thanks for your try .

Code:

---

Sub SourcePart()
Dim i As Long
    Dim Parts As Worksheet
    Dim SourcePart As Worksheet
    Dim F_Rng As Range
    Dim T_Str As String
    Dim L_Rw As Long
    Dim c As Range
   
    Set Parts = ThisWorkbook.Sheets("Sheet1")
   
    With Parts
        L_Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To L_Rw
            T_Str = .Cells(i, 1).Value
            For Each SourcePart In Workbooks("SourcePart.xlsx").Sheets
                With SourcePart


                    Set F_Rng = FindAll(.Range("A:P").Cells, T_Str, , xlWhole)
                    For Each c In F_Rng
                        If Not F_Rng Is Nothing And Not IsEmpty(F_Rng) Then
                            'F_Rng.Cells.Offset(, 1).EntireRow.Resize(, 5).Copy Parts.Cells(i, 1)
                            c.Cells.Offset(, 1).EntireRow.Resize(, 5).Copy Parts.Cells(i, 2)
                            Exit For
                        End If
                       
                Set F_Rng = .Range("A:P").Find(T_Str, , , xlWhole)
                If F_Rng Is Nothing Then
                MsgBox "Not Found"
                Exit Sub
                End If
                       
                    Next c
                End With
            Next SourcePart
        Next i
    End With
End Sub
 
 
 ' http://www.cpearson.com/Excel/FindAll.aspx
Function FindAll(SearchRange As Range, _
    FindWhat As Variant, _
    Optional LookIn As XlFindLookIn = xlValues, _
    Optional LookAt As XlLookAt = xlWhole, _
    Optional SearchOrder As XlSearchOrder = xlByRows, _
    Optional MatchCase As Boolean = False, _
    Optional BeginsWith As String = vbNullString, _
    Optional EndsWith As String = vbNullString, _
    Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' FindAll
    ' This searches the range specified by SearchRange and returns a Range object
    ' that contains all the cells in which FindWhat was found. The search parameters to
    ' this function have the same meaning and effect as they do with the
    ' Range.Find method. If the value was not found, the function return Nothing. If
    ' BeginsWith is not an empty string, only those cells that begin with BeginWith
    ' are included in the result. If EndsWith is not an empty string, only those cells
    ' that end with EndsWith are included in the result. Note that if a cell contains
    ' a single word that matches either BeginsWith or EndsWith, it is included in the
    ' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
    ' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
    ' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
    ' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
    ' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
    ' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
    ' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   
   
    Dim FoundCell As Range
    Dim FirstFound As Range
    Dim LastCell As Range
    Dim ResultRange As Range
    Dim XLookAt As XlLookAt
    Dim Include As Boolean
    Dim CompMode As VbCompareMethod
    Dim Area As Range
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim BeginB As Boolean
    Dim EndB As Boolean
   
   
   
   
    CompMode = BeginEndCompare
    If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
        XLookAt = xlPart
    Else
        XLookAt = LookAt
    End If
   
   
    ' this loop in Areas is to find the last cell
    ' of all the areas. That is, the cell whose row
    ' and column are greater than or equal to any cell
    ' in any Area.
   
   
    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
   
   
    On Error GoTo 0
    Set FoundCell = SearchRange.Find(what:=FindWhat, _
    after:=LastCell, _
    LookIn:=LookIn, _
    LookAt:=XLookAt, _
    SearchOrder:=SearchOrder, _
    MatchCase:=MatchCase)
   
   
    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False ' Loop forever. We'll "Exit Do" when necessary.
            Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
            End If
            If Include = True Then
                If ResultRange Is Nothing Then
                    Set ResultRange = FoundCell
                Else
                    Set ResultRange = Application.Union(ResultRange, FoundCell)
                End If
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address = FirstFound.Address) Then
                Exit Do
            End If
           
           
        Loop
    End If
   
    Set FindAll = ResultRange
   
   
End Function

---