word vba 将某列字符插入对应列的特定位置


Sub MergeAndClearWithColon()
    Dim tbl As Table
    Dim i As Long
    Dim rngCell2 As Range
    Dim rngCell3 As Range
    Dim pos As Long
    Dim originalText As String
    Set tbl = ThisDocument.Tables(1)
    For i = 21 To tbl.Rows.Count
        Set rngCell2 = tbl.Cell(i, 2).Range
        Set rngCell3 = tbl.Cell(i, 3).Range
        ' 去除单元格的结束字符(回车符)
        rngCell2.End = rngCell2.End - 1
        rngCell3.End = rngCell3.End - 1
        originalText = rngCell2.Text
        Dim productName As String
        productName = Trim(rngCell3.Text) ' 保存第3列的值并去除空格
        ' 查找"品名"位置(支持"品名"或"品名:")
        pos = InStr(1, originalText, "品名品牌")
        On Error Resume Next
        If pos > 0 Then
            ' 检查是否已有冒号
            Dim hasColon As Boolean
            hasColon = (Mid(originalText, pos + Len("品名"), 1) = ":") Or _
                (Mid(originalText, pos + Len("品名"), 1) = ":")
            
            ' 折叠到范围的开始位置
            ' 定位到"品名"后
            rngCell2.Collapse wdCollapseStart
            rngCell2.MoveStart wdCharacter, pos + Len("品名") - 1
            Debug.Print "是否", hasColon
            ' 插入冒号(如果没有)
            If Not hasColon Then
                Debug.Print i, "插入冒号"
                rngCell2.InsertAfter ":"
                'rngCell2.MoveEnd wdCharacter, 1
               
            End If
 
            ' 插入产品名称(替换原有内容)
            'rngCell2.MoveEnd wdCharacter, 0
            
            'rngCell2.MoveEnd wdCharacter, Len(rngCell2.Text) + 2 - pos - Len("品名") - IIf(hasColon, 1, 0)
            rngCell2.Text = ":" & productName
        Else
            ' 如果没有"品名",则在开头添加完整格式
            '  rngCell2.InsertBefore "品名:" & productName
            Debug.Print "无", i, tbl.Cell(i, i).Range.Text
        End If
 
        ' 清空第3列
        rngCell3.Text = ""
        ' 确保有换行符(如果原本有内容)
        If Len(originalText) > 0 And InStr(rngCell2.Text, vbCr) = 0 Then
            rngCell2.InsertAfter vbCr
        End If
    Next i
    
End Sub


image

image

posted @ 2025-08-08 18:41  geyee  阅读(13)  评论(0)    收藏  举报