将一些文本复制并粘贴到excel中的新列答案

【问题标题】：Copy and paste few text to a new column in excel将一些文本复制并粘贴到excel中的新列
【发布时间】：2014-06-03 05:37:29
【问题描述】：

您好 Excel 和宏专家，我有一个 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 列
听者3
12
34
11

第 4 列
页眉4
56
78
12

非常感谢任何帮助。

【问题讨论】：

你试过什么？请在您尝试或编写的特定代码或公式上发布特定问题。还要说明您的数据是什么样子的。
请编辑您的问题。不要在 cmets 中进行澄清。

标签： vba excel filter

【解决方案1】：

您也可以使用公式来执行此操作（除了替换 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

【讨论】：

很棒的宏，非常感谢。完美运行。感谢您的努力。
我应该修改代码的哪一部分以保持 A 列不变？
@user3156102 这是否意味着您不想单独拆分您所谓的第 1 列？或者您希望您的 Column 1 映射到 Column B, 2-->C 3-->D ？如果是后者，您只需在写入结果的最后几行之前将 r 设置为 r.offset(0,1) 。如果是前者，您可以更改正则表达式以始终将 col A 的内容写入 V(i,1)。
太棒了，这是一个快速的回复。非常感谢罗恩！！1
我修改了上面的代码，将A列中的X，Y数据复制到C列和D列。但是，如果B列中有数据，则数据将被删除。是否可以修改代码以使 B 列中的数据保持原样？

【解决方案2】：

我想出了一个可行的解决方案，但它依赖于格式与您描述的完全一样。例如，如果用户在 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

哦，附言您更新的问题描述比原来的要好一千倍，并且使问题可以回答。（尽管将来如果您积极尝试编写自己的代码或修改代码以适应您的需求，而不是仅仅尝试您发现的东西，那么您将获得更多的帮助）

【讨论】：