海量数据库关键词/货号结果宏

Question

我对 Excel 宏比较陌生，正在使用 Excel 2019。我们分配了一个项目，其中有 4000 个项目的数据库，带有图片。我们面临的挑战是建立一个搜索栏，在用户输入文本或数字并点击“搜索”按钮后，扫描数据库中的商品编号、描述中的单词或商人的关键字。我希望它找到结果，抓取它们（希望还有相邻的图片），然后将它们粘贴到“结果”页面中。

我的每一列都有一个标题，但如果您对这个项目有任何帮助，我们将不胜感激。

谢谢！

我希望它找到结果，抓取它们（希望还有相邻的图片），然后将它们粘贴到“结果”页面中。

如果宏找不到任何内容，还会弹出一个文本框，显示“未找到结果”。

Answer 1

添加一些打印内容以更好地描述数据库的外观会很有帮助

尝试下面的 VBA 并根据需要进行调整

Sub SearchDatabase()
    Dim wsData As Worksheet, wsResults As Worksheet
    Dim searchTerm As String
    Dim lastRow As Long, resultsRow As Long
    Dim cell As Range, found As Boolean
    
    ' Define your sheets
    Set wsData = ThisWorkbook.Sheets("Database") ' Replace "Database" with your actual sheet name
    Set wsResults = ThisWorkbook.Sheets("Results") ' Replace "Results" with your actual results sheet name
    
    ' Get the search term from the user
    searchTerm = wsData.Range("B1").Value ' Assume B1 is the search bar
    
    If Trim(searchTerm) = "" Then
        MsgBox "Please enter a search term.", vbExclamation
        Exit Sub
    End If
    
    ' Clear previous results
    wsResults.Cells.Clear
    wsResults.Rows(1).Value = wsData.Rows(1).Value ' Copy headers
    
    lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row
    resultsRow = 2
    found = False
    
    ' Search for matches
    For Each cell In wsData.Range("A2:A" & lastRow) ' Assuming data starts at row 2
        If InStr(1, cell.Value, searchTerm, vbTextCompare) > 0 Or _
           InStr(1, cell.Offset(0, 1).Value, searchTerm, vbTextCompare) > 0 Or _
           InStr(1, cell.Offset(0, 2).Value, searchTerm, vbTextCompare) > 0 Then
            
            found = True
            wsResults.Rows(resultsRow).Value = cell.EntireRow.Value
            
            ' Copy pictures if present
            Call CopyPictures(cell.Row, wsData, wsResults, resultsRow)
            resultsRow = resultsRow + 1
        End If
    Next cell
    
    ' Handle no results
    If Not found Then
        MsgBox "No results found.", vbInformation
    Else
        MsgBox "Search complete! Results displayed.", vbInformation
    End If
End Sub

Sub CopyPictures(rowNum As Long, wsData As Worksheet, wsResults As Worksheet, resultsRow As Long)
    Dim pic As Shape
    For Each pic In wsData.Shapes
        If Not Intersect(pic.TopLeftCell, wsData.Rows(rowNum)) Is Nothing Then
            pic.Copy
            wsResults.Paste wsResults.Cells(resultsRow, 1) ' Paste on the results sheet
            Exit For
        End If
    Next pic
End Sub