通过搜索数据集中的不同文本字段来自动编码数据集中的字段

Question

我是一个新手Excel宏编写器，并通过搜索/使用类似的东西论坛帖子产生了以下代码。我要做的是：我有一个大数据集，其中包含一个包含文本字符串的特定字段。它还有一个我为利润中心添加的新领域，目前是空白的。然后，我有一个单独的主数据表，其中包含两个字段 - 一个用于有时出现在数据集的文本字段中的可识别术语，另一个用于利润中心，如果它出现在文本字段中，则应该与该术语相关联。我想通过循环文本搜索，使用第二个表在数据集中填充尽可能多的利润中心。我想这需要循环取第一个数据集行，循环遍历所有主数据行，然后转到第二个数据集行，再循环遍历所有主数据行，依此类推（反之亦然）。

    Sub mySearch()

    Dim myData As Worksheet
    Dim myRules As Worksheet
    Dim myDataRow As Long
    Dim myRuleRow As Long
    Dim myLastDataRow As Long
    Dim myLastRuleRow As Long
    Dim myFind As String
    Dim myRule As String
    Dim Pos As Long

'   Specify name of Data sheet
    Set myData = Sheets("Data")

'   Specify name of Sheet with list of rules
    Set myRules = Sheets("Rules")

'   Assuming lists of data & rules start in column A on row 2, find last entries in lists
    myLastDataRow = myData.Cells(Rows.Count, "A").End(xlUp).Row
    myLastRuleRow = myRules.Cells(Rows.Count, "A").End(xlUp).Row

'   Application.ScreenUpdating = False

'   Loop through both lists - data & identification items

    For myDataRow = 2 To myLastDataRow

    For myRuleRow = 2 To myLastRuleRow
'       Get find and copy values (from columns A and B)
        myFind = myRules.Cells(myRuleRow, "A")
        myRule = myRules.Cells(myRuleRow, "B")
        myRules.Cells(myRuleRow, "B").Copy
'       Start at top of data sheet and do finding
        myData.Activate
'       Ignore errors that result from finding no matches
        On Error Resume Next
'       Do all pasting on column W of data sheet
        Pos = InStr(Range(myDataRow, "C"), "MyFind")
        If Pos > 0 Then Range(myDataRow, "W").Select.Paste
'       Reset error checking
        On Error GoTo 0

    Next myRuleRow

    Next myDataRow

'   Application.ScreenUpdating = True

    MsgBox "Searches complete!"

End Sub

代码正在运行完成，但未填充数据集中的利润中心字段。我认为这是相关利润中心的粘贴，我没有做对。有人可以帮帮我吗？谢谢，琳恩

Answer 1

这是一种略有不同的方法，使用字典存储利润中心密钥（“可识别条款”）及其从利润中心主列表中获取的相应利润中心ID，并使用range.Find方法识别主数据中的单元格包含这些条款。

Option Explicit

Public Sub FindProfitCentres()
    '// This approach uses a dictionary of profit centres to search for matching
    '// key value within a single column of text.

    '// The profit center key value text, to be matched, and their corresponding
    '// profit center IDs are in a 2-column table named "ProfitCenterLookup"

    '// The input data to be searched is in a two-column area named InputData -
    '// the first column being the text to be searched for matches against
    '// profit center keys, and the second column to be the place that the resulting
    '// profit center code, if found, is to be placed.


    '// PROFIT CENTER DICTIONARY
    '// First build a dictionary of string keys that identify profit centers
    '// NOTE: You must add a reference to Scripting Runtime in the Tools>References section
    '// of the VB dev window

    Dim oPCDict As New Scripting.Dictionary

    '// Get the profit center data table
    Dim rPCTable As Range
    Set rPCTable = Me.Range("ProfitCenterLookup")

    '// Save profit center data in the dictionary
    Dim ix As Integer
    For ix = 1 To rPCTable.Rows.Count
        With rPCTable.Rows(ix)
            If Len(.Cells(1, 1)) <> 0 Then
                '// Check for duplicate keys - these are ignored
                If Not oPCDict.Exists(.Cells(1, 1)) Then
                    oPCDict.Add .Cells(1, 1).Value, .Cells(1, 2).Value
                End If
            End If

        End With

    Next ix


    '// Get the list of the profit center keys from the dictionary
    '// We will use this list to do the search
    Dim aPCKeys() As Variant
    aPCKeys = oPCDict.Keys

    '// Variables
    Dim oResult As Range            'Result of .Find operation
    Dim sPrCenter As Variant        'Profit center code when found
    Dim rInputData As Range         '2-column area of input data
    Dim rSearchCol As Range         'Column 1 of this area - the text to be searched
    Dim rPrCtrCol As Range          'Column 2 of this area - where the pr center will be updated
    Dim sKey As String              'Profit center key to be found in the search data

    '// Get the input data, the search column and the output profit center column
    Set rInputData = Me.Range("InputData")
    Set rSearchCol = rInputData.Columns(1)
    Set rPrCtrCol = rInputData.Columns(2)

    '// Clear previously found profit centers from the output column
    rPrCtrCol.ClearContents

    '// Loop through each of the keys
    For ix = 0 To UBound(aPCKeys)

        '// Get the profit center key to be found
        sKey = aPCKeys(ix)

        '// Search for the first occurrence, if any, of the key in the search column
        Set oResult = rSearchCol.Find(sKey, LookIn:=xlValues, LookAt:=xlPart, Searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

        '// Check if the key was found and if so update the corresponding profit center
        Do Until (oResult Is Nothing)

            '// We have found a match on a specific key, we use this key
            '// to look up the profit center in the dictionary ...
            sPrCenter = oPCDict.Item(sKey)

            '// ... then place the profit center in the corresponding row of the sheet
            With rPrCtrCol.Cells(oResult.Row, 1)
                If Len(.Value) = 0 Then .Value = sPrCenter
            End With

            '// Go on to find the next match in the search area
            Set oResult = rInputData.Find(sKey, After:=oResult, LookIn:=xlValues, LookAt:=xlWhole, Searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        Loop

        '// Move on to the next profit center key
    Next ix
End Sub

Answer 2

在发布上一个答案之后，我发现有另一种方法可能对您更好 - 使用Excel能力直接从单元格调用UDF。

下面的代码用于UDF，它带有两个参数 - 第一个是要搜索“可识别术语”匹配的文本，第二个是对利润中心代码的2列表的引用。 UDF从表格的第2列返回利润中心名称，该表格与第1列中的代码列表中找到的第一个匹配项相对应。

我认为这种方法具有优势：不需要手动调用UDF来更新利润中心列 - 如果要更新要搜索的文本或利润中心表，则Excel会自动调用UDF;此外，您可以在电子表格的任何位置，任何工作表的任何列中使用UDF，如果需要，可以引用单个利润中心表或不同的表。这比依赖于特定命名范围的单个UDF灵活得多。可能存在性能劣势，但除非您拥有真正庞大的电子表格，否则这不太可能显着。

Option Explicit


Public Function ProfitCenter(rTextToCheck As Range, rPCTable As Range) As Variant
    '// Called as an in-cell formula to return the profit
    '// center code. The first parameter is the
    '// text to be searched, the second is a reference to
    '// table of profit center keys (col 1) and names (col 2)


    '// Get the string to be searched
    Dim sTTC As String
    sTTC = rTextToCheck.Cells(1, 1)

    '// Variables used in the loop
    Dim rPCKeyColumn As Range
    Dim rPCNameColumn As Range
    Dim rPCKey As Range
    Dim sPCKey As String
    Dim irow As Integer: irow = 0

    '// Get references to the keys and the names for profit centres
    Set rPCKeyColumn = rPCTable.Columns(1)
    Set rPCNameColumn = rPCTable.Columns(2)

    '// Find a match on one of the dictionary keys
    '// Run down the list of Profit Center keys
    For Each rPCKey In rPCKeyColumn.Cells
        irow = irow + 1

        '// Get the Profit center key for this row
        sPCKey = rPCKey.Value

        '// Check there is a key
        If Len(sPCKey) > 0 Then

            '// check for a match for the key within the text
            If InStr(sTTC, sPCKey) > 0 Then

                '// If a match is found, return the corresponding profit center name
                ProfitCenter = rPCNameColumn.Cells(irow, 1).Value
                Exit Function

            End If

        End If

    Next

    '// No match was found, so return blank
    '// (or else an error message such as "Not found")
    ProfitCenter = ""

End Function

UDF需要放在vba项目的vba模块中。然后，您只需在工作表的“利润中心”列中调用UDF，如下所示：