Hi All,
This workbook is designed for looking up Electronic component stock location and additional data, stock tracking and to compare against a bill of materials and output a list of parts on hand, and a new bill of materials for purchasing. Attached is the Workbook with lots of sample data for setting up the vba code for the searches.
I am using the code shown to create a table of rows found in several worksheets, this works fine and returns does create a table from the found data and creates a list of rows in a table for each worksheet. My problem is that it is finding the same data in a row were it has more than one value and returning that row as well, so the same row may show up more than once.
What I need to do is use the row number to check if it is allready in the list and bypass that row as it is allready in the table.
To do this I have to extrapolate the row number from the address were that data is found and check if it is in the table allready.
I need to use left, mid, right to return just the row number or is there an easy way to get it, even if the row number could be 1, 10, 100, 1000, 10000
Code:
Sub TextBox1_Click()
Dim ws As Worksheet, Found As Range
Dim myText As String, FirstAddress As String
Dim AddressStr As String, foundNum As Integer
Dim LastRow As Long
myText = Worksheets("instructions").Range("G6")
If myText = "" Then Exit Sub
re = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Address
Worksheets("instructions").Range("A16:BB100").Delete
For Each ws In ThisWorkbook.Worksheets
With ws
If ws.Name = "Instructions" Or ws.Name = "Storage Locations" Then GoTo myNext
t = ws.Name
Set Found = .Range("B3:AD10000").Find(What:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not Found Is Nothing Then
If Not foundNum > 1 Then
Worksheets("instructions").Range("A17").Value = "Sheet & Location"
tbl_start = Worksheets("instructions").Range("A" & 17 + foundNum).Address
tbl = Worksheets("instructions").Range("A" & "17" + foundNum).Address
Worksheets(ws.Name).Range("B2:L2").Copy
Worksheets("instructions").Range("B17").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
foundNum = foundNum + 1
Worksheets("instructions").Range("A" & 17 + foundNum).Value = "Sheet & Location"
tbl_start = Worksheets("instructions").Range("A" & 17 + foundNum).Address
tbl = Worksheets("instructions").Range("A" & 17 + foundNum).Address
Worksheets(ws.Name).Range("B2:L2").Copy
Worksheets("instructions").Range("B" & 17 + foundNum).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
FirstAddress = Found.Address
Do
foundNum = foundNum + 1
AddressStr = .Name & " " & Found.Address & vbCrLf
addr = Found.Address
Set Found = .Range("B3:AD10000").FindNext(Found)
row18 = foundNum + 17
Found.EntireRow.Copy Destination:=Worksheets("instructions").Range("A" & row18)
Worksheets("instructions").Range("AA1") = AddressStr
Range("AA1").Copy
Range("A" & row18).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
tt = ws.Name
ActiveSheet.Hyperlinks.Add Anchor:=Worksheets("instructions").Range("A" & row18), Address:="", SubAddress:=ws.Name + "!" + addr, TextToDisplay:=AddressStr
Range("A" & row18 & ":AD" & row18).Select
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeLeft).LineStyle = xlContinuous
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeLeft).Weight = xlThin
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeTop).LineStyle = xlContinuous
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeTop).Weight = xlThin
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeBottom).Weight = xlThin
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeRight).LineStyle = xlContinuous
Range("A" & row18 & ":AD" & row18).Borders(xlEdgeRight).Weight = xlThin
Range("A" & row18 & ":AD" & row18).Borders(xlInsideVertical).LineStyle = xlContinuous
Range("A" & row18 & ":AD" & row18).Borders(xlInsideVertical).Weight = xlThin
Range("A" & row18 & ":AD" & row18).Borders(xlInsideHorizontal).LineStyle = xlContinuous
Range("A" & row18 & ":AD" & row18).Borders(xlInsideHorizontal).Weight = xlThin
Loop While Not Found Is Nothing And Found.Address <> FirstAddress
End If
If Not Found Is Nothing Then
foundNum = foundNum + 1
ActiveSheet.ListObjects.Add(xlSrcRange, Range(tbl_start & ":$L$" & row18), , xlYes).Name = "Table" & foundNum
Call addborders
End If
myNext:
End With
Next ws
If Len(AddressStr) Then
Else:
MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation
End If
Dim lLastRow As Long, lLastColumn As Long
Dim lRealLastRow As Long, lRealLastColumn As Long
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("instructions").Range("G6").Select
End Sub