Tanyaann1995
Board Regular
- Joined
- Mar 24, 2021
- Messages
- 62
- Office Version
- 2016
- Platform
- Windows
Hi,
I need a code to find a part code (this part code is entered in Workbook B) in a list in Workbook A and then copy its corresponding description, global part code and price which are in the adjacent cells onto workbook B. The previous code I had used which is given below was with the If Else loop but this takes time if the list of part codes to search is very long. Attached pictures show how Workbook A and B looks like.
I need a code to find a part code (this part code is entered in Workbook B) in a list in Workbook A and then copy its corresponding description, global part code and price which are in the adjacent cells onto workbook B. The previous code I had used which is given below was with the If Else loop but this takes time if the list of part codes to search is very long. Attached pictures show how Workbook A and B looks like.
VBA Code:
Sub Price()
Dim pno As String
Dim LastRow As Long
Dim i As Integer
Dim LastRowinMainSheet As Long
Dim j As Integer
Dim f As Workbook
ThisWorkbook.Sheets.Add(After:=Sheets("Emerson COMMERCIAL OFFER")).Name = "Pricebook"
LastRowinMainSheet = Worksheets(2).Range("E:E").Find(What:="*", _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Set f = Workbooks.Open("\\emrsn.org\VC-Drive_N\AEDU1_INSIDE_SALES\SPARES\Pricelist.xlsx", True, True)
LastRow = f.Worksheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
f.Worksheets(1).Range("A1:U2").Copy
ThisWorkbook.Worksheets("Pricebook").Range("A1:U2").PasteSpecial (xlPasteAll)
For j = 24 To LastRowinMainSheet
pno = ThisWorkbook.Worksheets(2).Cells(j, 5).Value
For i = 3 To LastRow
If f.Worksheets(1).Cells(i, 2).Value = pno Then
ThisWorkbook.Worksheets(2).Cells(j, 4).Value = f.Worksheets(1).Cells(i, 3).Value
ThisWorkbook.Worksheets(2).Cells(j, 6).Value = f.Worksheets(1).Cells(i, 4).Value
ThisWorkbook.Worksheets(2).Cells(j, 7).Value = f.Worksheets(1).Cells(i, 5).Value
ThisWorkbook.Worksheets(2).Cells(j, 12).Value = f.Worksheets(1).Cells(i, 14).Value
f.Worksheets(1).Rows(i).Copy
ThisWorkbook.Worksheets("Pricebook").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End If
Next i
Next j
f.Close False
Set f = Nothing
End Sub
Attachments
Last edited by a moderator: