我只是 VBA 的初學者，我試圖在列旁邊的列上回傳部分匹配字串，其中包含我試圖在其中搜索的全文。這是我嘗試撰寫的代碼。什么是更好的方法來做到這一點？
基本上我有一個專欄：
第 1 列 aaaaa1111 ... zzzzz9999
第 2 欄
aaa bbb .. zzz
我想將第 2 列的值回傳到與第 1 列相鄰的列，其中第 2 列的字串可以在第 1 列中找到
Sub match()
Dim ws As Worksheet
Dim vendors As Range
Dim description As Range
Dim match As Range
Dim cell As Range
Dim j As Integer
Dim i As Integer
Set vendors = ws.Range("ae2:ae1007").Text
Set description = ws.Range("o2:o32609")
Set match = ws.Range("p2:p32609")
For i = 2 To 32609
For j = 2 To 1007
If InStr(description.Cells(i, "O"), vendors.Range(j, "AE")) > 0 Then
match.Cells(i, "P") = vendors.Range(j, "AE").Text
Else: match.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub
更新：（它仍然沒有運行 - 我在第 9 行不斷收到運行時錯誤“91”）
Sub match()
Dim ws As Worksheet
Dim cell As Range
Dim j As Integer
Dim i As Integer
For i = 2 To 32609
For j = 2 To 1007
If InStr(ws.Cells(i, "O"), ws.Cells(j, "AE")) > 0 Then
ws.Cells(i, "P") = ws.Cells(j, "AE").Text
Else: ws.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub
uj5u.com熱心網友回復：
您收到錯誤 91，因為您宣告ws但未設定ws任何作業表。
下面的代碼應該運行得非常快，因為它處理陣列中的資料（從單元格讀取/寫入是一個非常慢的程序）。
Option Explicit
Sub FindMatch()
Const vendorCol As String = "AE"
Const descCol As String = "O"
Const matchCol As String = "P"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change name accordingly
'==== Get a list of unique vendor names
Dim vendorDict As Object
Set vendorDict = CreateObject("Scripting.Dictionary")
vendorDict.CompareMode = vbTextCompare
Dim vendorLastRow As Long
Dim vendorInput As Variant
'Assign the values of the vendor names to array
vendorLastRow = ws.Cells(ws.Rows.Count, vendorCol).End(xlUp).Row
vendorInput = ws.Range(ws.Cells(2, vendorCol), ws.Cells(vendorLastRow, vendorCol)).Value
'Loop through the array and add to dictionary if it's not already in it
Dim n As Long
For n = 1 To UBound(vendorInput, 1)
If Not vendorDict.Exists(vendorInput(n, 1)) Then vendorDict.Add vendorInput(n, 1), 1
Next n
Dim vendorArr As Variant
vendorArr = vendorDict.keys
Set vendorDict = Nothing
Erase vendorInput
'====
'Assign the values of description to array
Dim descLastRow As Long
Dim descArr As Variant
descLastRow = ws.Cells(ws.Rows.Count, descCol).End(xlUp).Row
descArr = ws.Range(ws.Cells(2, descCol), ws.Cells(descLastRow, descCol)).Value
'Create an array of the same size as the description for match result, will be used to write in to the worksheet once at the end
Dim matchArr() As Variant
ReDim matchArr(1 To UBound(descArr, 1), 1 To 1) As Variant
'Loop through the description array and within the loop, check if there's a match in the vendor array
Dim i As Long
For i = 1 To UBound(descArr, 1)
For n = 0 To UBound(vendorArr)
If InStr(1, descArr(i, 1), vendorArr(n), vbTextCompare) <> 0 Then
'If match found, assign the vendor name to the match array
matchArr(i, 1) = vendorArr(n)
Exit For
End If
Next n
'If no match, return NA error
If matchArr(i, 1) = vbNullString Then matchArr(i, 1) = CVErr(xlErrNA)
Next i
ws.Cells(2, matchCol).Resize(UBound(matchArr, 1)).Value = matchArr
Erase descArr
Erase matchArr
End Sub
uj5u.com熱心網友回復：
比較兩列
- 這是一個回圈遍歷 column
O并將每個值與 column 中的每個值進行比較的基本示例AE。Match不好，因為 中的值AE需要包含在O. 您始終可以通過使用陣列來提高效率，如 Raymond Wu 的回答所示。 - 另一方面，您可以遍歷列
AE并使用Find和FindNext方法查找列O中的所有匹配項，這也可能更有效。
Option Explicit
Sub MatchVendors()
' s - Source (read from ('vendors'))
' d - Destination (read from ('description') and written to ('match'))
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1") ' adjust, often...
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1") ' ... different
Dim slRow As Long: slRow = sws.Range("AE" & sws.Rows.Count).End(xlUp).Row
If slRow < 2 Then Exit Sub ' no data in source
Dim srg As Range: Set srg = sws.Range("AE2:AE" & slRow)
Dim dlRow As Long: dlRow = dws.Range("O" & dws.Rows.Count).End(xlUp).Row
If dlRow < 2 Then Exit Sub ' no data in destination
Dim drg As Range: Set drg = dws.Range("O2:O" & dlRow)
Application.ScreenUpdating = False
Dim sCell As Range
Dim dCell As Range
Dim IsMatch As Boolean
For Each dCell In drg.Cells
' Read (Search)
For Each sCell In srg.Cells
' Either 'contains'...
If InStr(1, dCell.Value, sCell.Value, vbTextCompare) > 0 Then
' ... or 'begins with':
'If InStr(1, dCell.Value, sCell.Value, vbTextCompare) = 1 Then
IsMatch = True
Exit For
End If
Next sCell
' Write
If IsMatch Then
dCell.EntireRow.Columns("P").Value = sCell.Value
IsMatch = False
Else
dCell.EntireRow.Columns("P").Value = "#N/A"
End If
Next dCell
Application.ScreenUpdating = True
MsgBox "Vendors matched to Descriptions.", vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/370745.html