VBA：在单元格中searchmm的书写文本并复制

我有一个工作簿来定义两个部分之间的clearences。 我只需要将数字（维）与数字复制到另一个工作簿。

我试着用loggingmacros，但我找不到任何解决scheme。

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

当我运行macros我有下面的图片:(

我们可以把同一部分的行上的D列的间隙？

图片—-> macros观结果

Answer 3

我自己解决我的问题。 这个标题可以closures。

谢谢

 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