The attached file shows my progress so far, the find component on the instructions sheet works fine but I am having trouble with getting the vba code to work on the check_sheet sheet.
i need to search for a part, if found check for available qty if not enough keep checkinf for other locations in same sheet and other sheets, if still not enough add to list of purchases requied, otherwise add to list of in stock. I am trying to modify the code from the find part vba that does work for one part. trying one thing at a time, it still adds an extra line for when we don't have enough, into the list of have enough.
see attached file for sample, currently using various sample data for testing.
Component List and Locations .xlsm
Code:
Sub Macro6()
Dim ws As Worksheet
Dim lLastRow As Long, lLastColumn As Long
Dim lRealLastRow As Long, lRealLastColumn As Long
'first get sheet data and put it into the check sheet
Worksheets("check_sheet").Range("A17:Z1000").Delete
With Range("A1").SpecialCells(xlCellTypeLastCell)
lLastRow = .Row
lLastColumn = .Column
End With
lRealLastRow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
lRealLastColumn = Cells.Find("*", Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
If lRealLastRow < lLastRow Then
Range(Cells(lRealLastRow + 1, 1), Cells(lLastRow, 1)).EntireRow.Delete
End If
If lRealLastColumn < lLastColumn Then
Range(Cells(1, lRealLastColumn + 1), Cells(1, lLastColumn)).EntireColumn.Delete
End If
ActiveSheet.UsedRange 'Resets LastCell
Number_of_parts = 10 'InputBox("Enter the number of units required")
Part_Col = "E" 'InputBox("Enter the Column of the Part Number to check")
qty_col = "CP" 'InputBox("Enter the Column to check for the required Quantity")
Start_Row = 3 'InputBox("Enter the number of the First Row to check")
ttttt = 0
Sheets("Check_Sheet").Select
str_rng = Part_Col & Start_Row
Last_Row = ActiveSheet.Range("c3").SpecialCells(xlCellTypeLastCell).Row
For i = 1 To Last_Row
If Not IsEmpty(foundNum) Then
find_it = Range(Part_Col & Start_Row + foundNum) ' first cell to check
Else
find_it = Range(Part_Col & Start_Row).Value ' first cell to check
End If
For Each ws In ThisWorkbook.Worksheets
With ws
If ws.Name = "Manufacturers & Suppliers" Or ws.Name = "Check_Sheet" _
Or ws.Name = "Instructions" Or ws.Name = "Storage Locations" _
Or ws.Name = "Check Sheet" Or ws.Name = "Output_Required" _
Or ws.Name = "Output_Have" Then
GoTo Next_ws
End If
t = ws.Name
Set Found = .Range("F3:F10000").Find(What:=find_it, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not Found Is Nothing Then
X = Found.Address
y = Found.Row
yy = "$" & qty_col & "$" & y
ttt = Worksheets("Check_sheet").Range(yy).Value
aaa = Worksheets(t).Range("$D$" & y).Value
If ttt * Number_of_parts < aaa Then
'have_enough, copy to output_have, goto next part
FirstAddress = Found.Address
If ttttt <> 1 Then foundNum = foundNum + 1
AddressStr = .Name & " " & Found.Address & vbCrLf
addr = Found.Address
Set Found = .Range("F3:F10000").FindNext(Found)
r1 = Found.Row
Worksheets("check sheet").Range("A1" & foundNum).Value = r1
row18 = foundNum + 17
Found.EntireRow.Copy Destination:=Worksheets("check_sheet").Range("A" & row18)
Worksheets("check_sheet").Range("AA1") = AddressStr
Range("AA1").Copy
Range("A" & row18).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Worksheets("check_sheet").Range("B" & row18) = ttt * Number_of_parts
Else
'not enough, check for more locations, if not then copy to output_required
' FirstAddress = Found.Address
foundNum = foundNum + 1
ttttt = 1
Worksheets("check sheet").Range("A1:A1000").Delete
Worksheets("check sheet").Range("AA1").Delete
Worksheets("check_sheet").Range("b" & row18) = ttt * Number_of_parts
End If
End If
End With
Next_ws:
Worksheets("check sheet").Range("A1:A1000").Delete
Worksheets("check sheet").Range("AA1").Delete
Next ws
i = i + 1
Next i
Worksheets("check sheet").Range("A1:A1000").Delete
Worksheets("check sheet").Range("AA1").Delete
If Len(AddressStr) Then
Else:
MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
With Range("A1").SpecialCells(xlCellTypeLastCell)
lLastRow = .Row
lLastColumn = .Column
End With
lRealLastRow = Cells.Find("*", Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
lRealLastColumn = Cells.Find("*", Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
If lRealLastRow < lLastRow Then
Range(Cells(lRealLastRow + 1, 1), Cells(lLastRow, 1)).EntireRow.Delete
End If
If lRealLastColumn < lLastColumn Then
Range(Cells(1, lRealLastColumn + 1), Cells(1, lLastColumn)).EntireColumn.Delete
End If
ActiveSheet.UsedRange 'Resets LastCell
Worksheets("check_sheet").Range("A18").Select
Worksheets("check_sheet").Range("G5").Select
End Sub