在Excel邏輯上分析字符串到近修剪複製

Question

假設字符串：

item1, item1N, item1Z, item1fhg, item1_any_letters, item2, item3, item3N, item3H 

我的目標產量是根本

item1, item2, item3 

這是大約10萬行Excel的當前文件，但可以遷移到另一個程序等，如果需要臨時。

基本上我需要確定重複項（以數字結尾的任何初始短語），而不考慮數字後面的字母。例如，某些短語可能具有「品牌item2，品牌item34」，唯一的決定因素是數字之後的任何和所有術語。

關於從哪裏開始的任何想法？每個字符串通常有2到500個值，用逗號和空格隔開。沒有逗號跟隨最終值。

Answer 1

Sub Tester() 

    Dim re As Object, match As Object 
    Dim dict As Object 
    Dim arr, arrItems, x As Long, y As Long 
    Dim val, matches, valMatch 


    Set dict = CreateObject("scripting.dictionary") 
    Set re = CreateObject("VBScript.RegExp") 
    re.Pattern = "([\w ]+\d+)" 
    re.ignorecase = True 
    re.Global = True 

    arr = ActiveSheet.Range("A1:A100").Value 

    For x = LBound(arr, 1) To UBound(arr, 1) 
     arrItems = Split(arr(x, 1), ",") 
     dict.RemoveAll 
     For y = LBound(arrItems) To UBound(arrItems) 

      val = Trim(arrItems(y)) 

      If re.Test(val) Then 
       Set matches = re.Execute(val) 
       valMatch = matches(0).Value 
       If Not dict.exists(valMatch) Then dict.Add valMatch, 1 
      End If 
     Next y 

     Debug.Print arr(x, 1) 
     Debug.Print Join(dict.keys, ",") 'where do you want this? 

    Next x 

End Sub 

Answer 2

這可能是不完美的，因爲它是一個快速入侵，它只能刪除最右邊的非數字字符串。您將需要一些正則表達式知識來調整它以滿足您的需求。

無論如何，遵守給出here的「安裝」的步驟，保存模塊，你就可以在您的工作表一個公式來寫，如

=S(A1;"[^0-9]*$";"") 

，比如說

，在B1單元格。如果A1單元格包含「Item 1234 blah blah」，則B1現在將包含「Item 1234」。將公式拖到列B的所有單元格中，並將值保存到另一個Excel文件進​​行排序（或者您可以嘗試排序和就地子排序）。

不幸的是，我不認爲在10萬個以上的電池中這樣做是可行的（我甚至建議不要在就地進行小計）。

通過爲Windows安裝textools（sed，grep，uniq ...）並通過過濾器運行您的文件，您將會得到更好的服務。假設每一行代表一個項目如上，作爲

sed -e 's/^\([^0-9][^0-9]*[0-9][0-9]*\).*/\1/g' | sort | uniq -c | sort -rn 

這樣的過濾器會得到你的10萬線的文件，並返回類似

79283 Item 1 
1234 Item 2 
    993 Item 3 
    .......... 

（你可以寫一些平臺（\ d + \ d +）而不是（[^ 0-9] ...，但我不確定Windows的行爲）

更好的工具選擇是（草莓）Perl，它也支持CSV，或者Python語言。

Answer 3

一個VBA的做法是somehwat類似於蒂姆的第一個途徑

1. 使用RegExp，刪除無效charcaters（字符數後和前一個逗號）

2. 消除與
   重複a）使用Dictionary
   b）中的Excel的內置刪除重複功能（寫入到片材）

   Const strDelim = ", " 
   
   Sub TestMe() 
   Dim strTest As String 
   Dim x 
   strTest = "item1, item1N, item1Z, item1fhg, item1_any_letters, item2, item3, item3N, item3H" 
   x = Split(DeDupe(strTest), strDelim) 
   'fix last element 
   x(UBound(x)) = Left$(x(UBound(x)), Len(x(UBound(x))) - 1) 
   Call Method2(x) 
   End Sub 
   
   Sub Method2(ByVal x) 
   Dim objDic As Object 
   Dim y As Variant 
   Set objDic = CreateObject("Scripting.Dictionary") 
   Dim lngRow As Long 
   For lngRow = LBound(x) To UBound(x) 
   objDic(x(lngRow)) = 1 
   Next lngRow 
   MsgBox Join(objDic.keys, strDelim) 
   End Sub  
   
   Function DeDupe(strIn As String) As String 
   Dim objRegex As Object 
   Set objRegex = CreateObject("vbscript.regexp") 
   With objRegex 
   .Global = True 
   .Pattern = "(.+?\d+)[^\d]+(,|$)" 
   DeDupe = .Replace(strIn, "$1,") 
   End With 
   End Function 
   

Option B

'another potential option. Not applied in this code 
    Sub Method1(ByVal x) 
    Dim y As Variant 
    Dim rng1 As Range 
    With ActiveSheet 
    .[a1].Resize(UBound(x) + 1, 1) = Application.Transpose(x) 
    .Columns("A").RemoveDuplicates Columns:=1, Header:=xlNo 
    y = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp))) 
    End With 
    MsgBox Join(y, strDelim) 
    End Sub