VBA：在單元格中搜索mm的書面文本並復制

Question

我有一個工作簿來定義2個部分之間的間隙。 我只需要將帶有數字的mm（維度）復制到另一本工作簿中。

我嘗試了w /錄制宏，但找不到任何解決方案。

Answer 1

您可以嘗試以下方法：

Option Explicit

Sub main2()
    Dim destinationWS As Worksheet
    Dim cell As Range
    Dim clearances As Variant
    Dim iClearance As Long

    Set destinationWS = Workbooks("destinationWorkbookName").Worksheets("destinationWorksheetName") '<--| change "destinationWorkbookName" and "destinationWorksheetName" to your actual names

    With Range("C1", Cells(Rows.Count, "C").End(xlUp))
        .AutoFilter Field:=1, Criteria1:="*mm*"
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
            With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
                ReDim clearances(1 To .Count)
                For Each cell In .Cells
                    iClearance = iClearance + 1
                    clearances(iClearance) = GetClearance(cell.Value)
                Next cell
            End With
            destinationWS.Range("A1").Resize(UBound(clearances)).Value = Application.Transpose(clearances)
        End If
        .Parent.AutoFilterMode = False
    End With
End Sub

Function GetClearance(strng As String) As String
    Dim word As Variant

    For Each word In Split(strng, " ")
        If InStr(word, "mm") > 0 Then
            GetClearance = word
            Exit For
        End If
    Next
End Function

Answer 2

當我運行宏時，我得到下面的圖片:(

我們可以將間隙放到同一零件行的D列嗎？

圖片----> 宏結果

Answer 3

我自己解決問題。 該標題可以關閉。

謝謝

Sub aaa()
    Set Rky = CreateObject("VBScript.RegExp")
    Rky.Pattern = "\w*([0-9])" & "mm"
    For i = 1 To Range("A65536").End(3).Row
      If Cells(i, "a").Value Like "*mm*" Then
        Cells(i, "C") = Rky.Execute(Cells(i, "A")).Item(0)
      End If
    Next i
End Sub