Question

Hello Excel和Macro专家，我有一张excel表，其中特定列包含以下文本

abcdef x：12 Y：56
qwertyuiop x：34 Y：78
asdfghlkjhfda x：11 Y：12

任务是识别X：之后出现的数字，并将它们粘贴到特定列。 Y：之后所遵循的数字也应该粘贴到另一列。可能存在不显示X和Y值的行，在这种情况下，不需要将任何内容粘贴到列。我在网上搜索但找不到符合我要求的任何内容。

我尝试了以下在网络上找到的宏。

Sub Macro1()
  Dim MatchString As String
  MatchString = "X: *"
  For Counter = 1 To Range("B:B").Count
    If (Left(Range("B" & Counter).Value, Len(MatchString)) = MatchString) Then
      Range("B" & Counter).Select
      Selection.Cut
      Range("D" & Counter).Select
      ActiveSheet.Paste
    End If
  Next Counter
End Sub

编辑：显示结果的不同目标列，而不是原始帖子 EDIT2：显示要考虑的列标题

进一步澄清以下是Excel数据
第1栏听徒1 abcdef x：12 Y：56
qwertyuiop x：34 Y：78
asdfghlkjhfda x：11 Y：12

Column3和Column4没有任何数据

运行宏后，应显示如下
第1栏标题1 ABCDEF
QWERTYUIOP
asdfghlkjhfda

第3栏 Hearder3
12个
34个
11

第4栏标题4
56个
78个
12

非常感谢任何帮助。

Answer 1

我已经提出了一个有效的解决方案，但它依赖于格式化，正如您所描述的那样。例如，如果用户在X：和它赢得的号码之间有多于1个空格。（你可以建立一些更复杂的东西来检查这个）。

假设：

X将始终是第一个定义的值
数字总是2位数

X和数字（或Y和数字）之间不包含多余的空格

Sub changeText()

Dim lastRow As Integer
Dim completeString As String
Dim xPos As Integer
Dim yPos As Integer

'stop screen updating (speeds things up)
Application.ScreenUpdating = False

'set it so it is using the active sheet
With ActiveSheet
    'find the last row of data
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    'iterate through the rows until end (change i = 1 line to account for headings etc)    
    For i = 1 To lastRow
        'get the string from the cell
        completeString = Cells(i, 1).Value

        'find where the X: and Y: start                
        xPos = InStr(completeString, "X:")
        yPos = InStr(completeString, "Y:")
        'set the cells values to the first string, the X value and the Y value
        Cells(i, 1).Value = Left(completeString, xPos - 1)
        Cells(i, 2).Value = Mid(completeString, xPos + 3, 2)
        Cells(i, 3).Value = Mid(completeString, yPos + 3, 2)



    Next i

End With
'update screen again
Application.ScreenUpdating = True

End Sub

哦和P.S.您更新的问题描述比原始问题好一千倍，并使问题得到回答。（虽然将来你会得到更多人的帮助，如果你主动尝试编写自己的代码或修改一个适合的代码，而不是只是尝试你找到的东西）

Answer 2

您也可以使用公式执行此操作（替换A列的内容除外，您可以使用公式后的复制/粘贴特殊值

第一部分：

=TRIM(LEFT($A1,MIN(SEARCH({"x:","y:"},$A1&"x:y:"))-1))

x之后的数字：

=IFERROR(LOOKUP(1E+307,--MID($A1,SEARCH("x:",$A1)+3,ROW(INDIRECT("1:99")))),"")

y之后的数字：

=IFERROR(LOOKUP(1E+307,--MID($A1,SEARCH("y:",$A1)+3,ROW(INDIRECT("1:99")))),"")

如果你真的想要一个宏，以下应该可以解决问题。它假设您的数据位于以A1开头的A列中。如有必要，可以轻松更改起点。它将覆盖A列.X和Y可以按任何顺序排列，也可以不存在。但它确实假设数字都是整数。如果它们可能是小数，那么如果我们知道是否存在强制整数部分，则可以很容易地解释这一点。

编辑：代码已更改为OP的已编辑要求，说明进程结果位于A，C和D列，且B列保留：

EDIT2：代码被更改以维护标头和格式

Option Explicit
Option Compare Text
Sub SplitAtXY()
    Dim R As Range
    Dim V As Variant
    Dim RE As Object, MC As Object
    Dim S As String
    Dim I As Long
    'Next line not needed since we are maintaining pre-existing format
    'Const lMinColWidth As Long = 10 '<--change as needed for appearance of results

V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=2)

Set RE = CreateObject("vbscript.regexp")
With RE
    .ignorecase = True
    .Pattern = "^(.*?)\s*([xy]):\s*(\d+)\s*(?!\2)([xy]):\s*(\d+)"
    .MultiLine = True
End With

ReDim Preserve V(1 To UBound(V), 1 To 4)
For I = 2 To UBound(V) '<--changed to 2 to maintain header rows as in original
        S = V(I, 1)
        If RE.test(S) Then
            Set MC = RE.Execute(S)
            V(I, 1) = MC(0).submatches(0)
            Select Case MC(0).submatches(1)
                Case "x"
                    V(I, 3) = MC(0).submatches(2)
                    V(I, 4) = MC(0).submatches(4)
                Case "y"
                    V(I, 3) = MC(0).submatches(4)
                    V(I, 4) = MC(0).submatches(2)
            End Select
        Else
            V(I, 1) = S
        End If
Next I

Set R = Range("a1").Resize(rowsize:=UBound(V, 1), columnsize:=UBound(V, 2))
Application.ScreenUpdating = False

With R
    .EntireColumn.ClearContents '<--Changed to ClearContents to maintain previous formats
    .Value = V
    .EntireColumn.AutoFit
    For I = 1 To 4
        .Columns(I).ColumnWidth = WorksheetFunction.Max(.Columns(I).ColumnWidth, lMinColWidth)
    Next I
End With

Application.ScreenUpdating = True
End Sub

将少量文本复制并粘贴到excel中的新列

2 个答案: