在Excel VBA项目的匹配相似，但并不确切文本字符串在Excel VBA项目的匹配相似，但并不确

好吧，我一直在试图找到一个解决方案，我似乎就是不能够。我甚至不能正常分解的问题。这是这个想法。

我有两片与许多行（一个具有800和其他与300,000）。每一行包含一个名称列，并包含有关这一名称的信息，然后几列。各片材具有不同种类的信息。

我想这两个表合并为基于此名称列，他们都有一个主表，所以整合功能是为这个完美的。现在的问题是，名称不完全匹配。

例如Sheet1中包含

“公司BV”， “信息＃1”
“公司合计”，“信息＃2”
“有限责任公司”，“信息＃3”

和片2包含

“公司与公司”，“信息＃4”
“公司与合作”，“信息＃5”

片1包含的所有将要使用（100左右，但在不同的形式如上所述）和片材2包含所有这些100在不是在100列表，因此我不多行加上名称的名称关心。

我将如何做一个VBA代码项目中，最终的结果会是这样，主表：

“公司”， “信息＃1”， “信息＃2”， “信息＃3”， “信息＃4”， “信息＃5”

对于每一个“公司”（100表）在那里？

我也希望有一个解决方案。我很新的VBA项目，但我以前做过一些少量的编码。

Answer 1:

我把你的个人部分的宏，这样的宏在所有工作表可用。通过记录一个虚拟宏做到这一点，并选择将其存储在个人宏工作簿。现在，您可以手动在这个个人工作簿中添加新宏的和功能。

我只是想这一个（不知道原来的源）和它工作正常。

式如下所示：= PERSONAL.XLSB FuzzyFind！（A1，B $ 1：乙$ 20）

该代码是在这里：

Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
For Each cell In tbl_array
  str = cell
  For i = 1 To Len(lookup_value)
    If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
      a = a + 1
      cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
    End If
  Next i
  a = a - Len(cell)
  If a > b Then
    b = a
    Value = str
  End If
  a = 0
Next cell
FuzzyFind = Value
End Function

Answer 2:

我用罗伯特解决方案，它为我工作得很好。我张贴整个人谁对Excel是新的解决方案，但都知道编码：

虽然这个线程是旧的，但我花了一些代码从另一个线程和尝试，看起来像解决方案是给大约匹配。在这里，我想sheet1中的一列与Sheet2中的一列匹配：

在Excel add命令按钮
把下面的代码，然后点击/运行按钮和功能给你造成选定列

 Private Sub CommandButton21_Click()
     Dim ws As Worksheet
     Dim LRow As Long, i As Long, lval As String


   '~~> Change this to the relevant worsheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

With ws
    '~~> Find Last Row in Col G which has data
    LRow = .Range("D" & .Rows.Count).End(xlUp).Row

    If LRow = 1 Then
        MsgBox "No data in column D"
    Else
        For i = 2 To LRow


             lval = "D"
            .Range("G" & i).Value = FuzzyFind(lval & i, .Range("PWC"))
        Next i
    End If
    End With

    End Sub


    Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
    Dim i As Integer, str As String, Value As String
    Dim a As Integer, b As Integer, cell As Variant

    For Each cell In tbl_array
     str = cell
     For i = 1 To Len(lookup_value)
      If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
     a = a + 1
     cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid   (cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
    End If
     Next i
     a = a - Len(cell)
     If a > b Then
       b = a
       Value = str
    End If
       a = 0
    Next cell
      If Value <> "" Then
         FuzzyFind = Value
      Else
         FuzzyFind = "None"
      End If
End Function