按大写字母拆分单元格内容并粘贴至多单元格的VBA实现问题

需要实现的功能：从Sheet2中找到对应员工的姓名后，按大写字母开头的规则拆分姓名（比如"John Michael Smith"拆分为"John"、"Michael"、"Smith"），并依次写入Sheet1的C19、C20、C21等连续单元格中。

原代码的问题：只是将拆分后的姓名拼接成带空格的字符串，每次循环都覆盖Sheet1的C19单元格，没有实现拆分后逐行写入的核心需求。

修改后的完整代码 #

Private Sub Splitnames_Click()
    Dim I As Integer
    Dim WS1 As Worksheet: Set WS1 = Worksheets("sheet1")
    Dim WS2 As Worksheet: Set WS2 = Worksheets("sheet2")
    Dim MyValue As String
    Dim FoundCell As Range
    Dim NameStr As String
    Dim SplitWords As String
    Dim rowNum As Integer ' 记录写入的起始行
    
    MyValue = InputBox("Please enter employee name...", "Import employee", "Enter employee name here...")
    WS1.Range("E44").Value = MyValue
    
    Set FoundCell = WS2.Range("A2:A1000").Find(WS1.Range("E44").Value, LookIn:=xlValues, LookAt:=xlPart)
    If FoundCell Is Nothing Then
        MsgBox "No Employee found!"
        Exit Sub
    Else
        NameStr = Trim(FoundCell.Offset(rowOffset:=0, columnOffset:=16).Value)
        SplitWords = Left(NameStr, 1)
        rowNum = 19 ' 起始写入行C19
        
        For I = 2 To Len(NameStr)
            ' 遇到大写字母且前一个字符不是空格时，写入当前段并准备下一段
            If (Asc(Mid(NameStr, I, 1)) > 64) And (Asc(Mid(NameStr, I, 1)) < 91) And (Mid(NameStr, I - 1, 1) <> " ") Then
                WS1.Range("C" & rowNum).Value = SplitWords
                rowNum = rowNum + 1
                SplitWords = Mid(NameStr, I, 1)
            Else
                SplitWords = SplitWords & Mid(NameStr, I, 1)
            End If
        Next I
        
        ' 写入最后一段姓名（循环中未处理的部分）
        WS1.Range("C" & rowNum).Value = SplitWords
    End If
    
    ' 释放对象资源
    Set FoundCell = Nothing
    Set WS1 = Nothing
    Set WS2 = Nothing
End Sub

关键修改说明 #

• 新增rowNum变量跟踪当前写入的行号，初始值设为19（对应C19）
• 调整拆分逻辑：当检测到大写字母且前一个字符不是空格时，先将当前累积的姓名段写入单元格，行号自增后重置姓名段
• 循环结束后单独写入最后一段姓名（循环仅在遇到下一个大写字母时写入上一段，最后一段无后续触发条件）
• 变量命名更规范（避免Name这类VBA内置关键字），提前声明所有变量符合最佳实践

内容的提问来源于stack exchange，提问作者Wonton Animal Chin