VBA按条件复制单元格至右侧列报错：对象未定义

问题分析 #

你遇到的“对象未定义”错误，根源在于这两行逻辑错误的代码：

Selection.Copy
c.Offset(0, 1).Value.Paste

• c.Offset(0,1).Value是单元格的值属性（不是对象），根本无法调用Paste方法；
• Selection.Copy复制的是你选中的区域，和当前正在处理的单元格c完全无关，而且这个需求完全没必要用复制粘贴来实现。

你的核心需求是提取单元格的第一个单词（比如从CENTRUM ADVANCE TABLET中取CENTRUM），直接通过文本拆分就能轻松实现。

修正后的完整代码 #

Sub splitUpRegexPattern()
    Dim re As Object, c As Range
    Dim allMatches As Object
    
    ' 初始化正则表达式对象
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "((\d+(?:\.\d+)?)\s*(m?g|mcg|ml|IU|MIU|mgs|µg|gm|microg|microgram)\b)"
    re.IgnoreCase = True
    re.Global = True
    
    ' 遍历D列从D2开始的所有非空单元格（避免空单元格中断循环）
    For Each c In ActiveSheet.Range("D2", ActiveSheet.Cells(ActiveSheet.Rows.Count, "D").End(xlUp)).Cells
        Set allMatches = re.Execute(c.Value)
        
        If allMatches.Count > 0 Then
            ' 正则匹配到内容，取第一个匹配项写入右侧单元格
            c.Offset(0, 1).Value = allMatches(0)
        Else
            ' 未匹配到，提取第一个单词
            If InStr(c.Value, " ") > 0 Then
                ' 找到第一个空格，截取左侧文本
                c.Offset(0, 1).Value = Left(c.Value, InStr(c.Value, " ") - 1)
            Else
                ' 单元格无空格，直接取全部内容
                c.Offset(0, 1).Value = c.Value
            End If
        End If
    Next c
End Sub

关键修改说明 #

1. 移除无效复制粘贴逻辑：替换为直接提取第一个单词的代码，用InStr定位第一个空格，再用Left截取目标文本，完全不需要剪贴板操作；
2. 优化循环范围：把原代码中Range("D2").End(xlDown)的写法改为Cells(Rows.Count, "D").End(xlUp)，避免D2以下出现空单元格时，循环范围提前终止；
3. 增加边界处理：当单元格内容只有单个单词（无空格）时，直接把整个内容赋值给右侧单元格，避免出现错误。

额外优化选项 #

如果你需要更灵活的单词拆分（比如自动忽略开头的空格），可以用Split函数替代InStr和Left：

' 替换Else块的代码
Dim wordArr As Variant
wordArr = Split(Trim(c.Value), " ")
c.Offset(0, 1).Value = wordArr(0)

这个写法会自动去除单元格内容开头的空格，直接取第一个拆分后的元素，适配更多文本格式。

内容的提问来源于stack exchange，提问作者MC12