PDA

View Full Version : if find the matched data in another workbook copy the complete row



parscon
02-13-2014, 03:33 PM
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



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

parscon
02-14-2014, 01:41 AM
I changed my code from



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



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.

westconn1
02-14-2014, 03:12 AM
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

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

parscon
02-14-2014, 04:42 AM
it is not work the same result , fi you check the attachment on post #2 you can see the result .

Please help me :(

Kenneth Hobs
02-14-2014, 07:02 AM
Can you post a sheet showing what you expected to be imported?

parscon
02-14-2014, 07:19 AM
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 .

Kenneth Hobs
02-14-2014, 08:09 AM
Use IsEmpty():

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

parscon
02-14-2014, 10:07 AM
Really you are talent and you fixed my problem .

parscon
02-15-2014, 01:39 AM
Thank you Kenneth Hobs

parscon
02-25-2014, 03:10 PM
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

Kenneth Hobs
02-25-2014, 09:13 PM
I don't have time to test this right now. It should go something like:

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

parscon
02-26-2014, 01:01 AM
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



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


Thank you again

Kenneth Hobs
02-26-2014, 06:37 AM
c.Cells.Offset(, 1).EntireRow.Resize(, 5).Copy Parts.Cells(i, 1)

parscon
02-26-2014, 06:47 AM
Thank you again but another error appear :

Run-time error '424': Object required



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

Kenneth Hobs
02-26-2014, 06:58 AM
Obviously, the FindAll() did not find anything. You will need to check that after the Set by:

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

parscon
02-26-2014, 07:10 AM
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 .



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