从 Word 到 Excel 的多级列表

Question

我需要的结果是将 MS Word 中的多级列表分布在 excel 的列中，然后将多级列表指示器移动到自己的列中。 现在我的代码删除了多级列表指示器。 我有一个解决方案，但它不适用于 a. 通过 z。 多级列表指示符，因为句子末尾有一个字母和句点，并且代码正在删除句子的最后一个字母和句点。 我需要将代码转换为 select 左侧的字母句点或数字句点，字符串的开头。 此外，我无法将方括号“[]”读取为字符串，我必须声明每次出现。 有没有办法将“[]”标识为字符串的一部分？ 此代码将多级列表复制到正确的列。 我只需要它来移动数字或字母的内容。 示例：1. 或 a. or (1) or (a) or 1 or [a] 在字符串的开头。 这是我用来根据多级列表指示器移动单元格内容的代码。 我用于在将多级列表移动到列后删除它的第二个代码。 最终，我想将多级列表指示器移动到其内容同一行的自己的列中。 最终，我想将多级（例如：1. 或 a. 或 (1) 或 (a) 或1或 [a]）移动到该级别内容旁边的列中。 word中的多级列表

字表复制粘贴到excel

1.这是1级。 这是第 2 级。当我删除列表指示器时，最后一个字母和句点消失了。 (1) 这是第 3 级。 (a) 这是第 4 级。 1这是第 5 级。如何在字符串中使用方括号。 [a] 这是第 6 级。 1) 这是第 7 级。

excel 所需 output

Sub Findandcut()
Dim row As Long

For row = 1 To 1000

    If Range("A" & row).Value Like "(#)" Then
        ' Copy the value and then blank the source.
        Range("C" & row).Value = Range("A" & row).Value
        Range("A" & row).Value = ""
    End If

    If Range("A" & row).Value Like "[a-z].*" Then
        ' Copy the value and then blank the source.
        Range("B" & row).Value = Range("A" & row).Value
        Range("A" & row).Value = ""
    End If

     If Range("A" & row).Value Like "(#)*" Then
        ' Copy the value and then blank the source.
        Range("C" & row).Value = Range("A" & row).Value
        Range("A" & row).Value = ""
    End If

    If Range("A" & row).Value Like "([a-z])*" Then
        ' Copy the value and then blank the source.
        Range("D" & row).Value = Range("A" & row).Value
        Range("A" & row).Value = ""
    End If

Next

结束子

Sub remove_BulletsCol_B()
Dim str1 As String
Dim str2 As String
Dim rngTemp As Range
Dim rngCell As Range
str1 = "a."
str2 = "b."
str3 = "c."
str4 = "d."
str5 = "e."
str6 = "f."
str7 = "g."
str8 = "h."
str9 = "i."
str10 = "j."
str11 = "k."
str12 = "l."
str13 = "m."
str14 = "n."
str15 = "o."
str16 = "p."
str17 = "q."
str18 = "r."
str19 = "s."
str20 = "t."
str21 = "u."
str22 = "v."
str23 = "w."
str24 = "x."
str25 = "y."
str26 = "z."

'Set rngTemp
Set rngTemp = Cells(1, 1).CurrentRegion 'You range goes here

'Loop through range and replace string
For Each rngCell In rngTemp

If InStr(1, rngCell, str1) > 0 Then
    rngCell = Replace(rngCell.Value, str1, "")
End If

If InStr(1, rngCell, str2) > 0 Then
    rngCell = Replace(rngCell.Value, str2, "")
End If
    If InStr(1, rngCell, str3) > 0 Then
    rngCell = Replace(rngCell.Value, str3, "")
End If
    If InStr(1, rngCell, str4) > 0 Then
    rngCell = Replace(rngCell.Value, str4, "")
End If
    If InStr(1, rngCell, str5) > 0 Then
    rngCell = Replace(rngCell.Value, str5, "")
End If
    If InStr(1, rngCell, str6) > 0 Then
    rngCell = Replace(rngCell.Value, str6, "")
End If
    If InStr(1, rngCell, str7) > 0 Then
    rngCell = Replace(rngCell.Value, str7, "")
End If
    If InStr(1, rngCell, str8) > 0 Then
    rngCell = Replace(rngCell.Value, str8, "")
End If
    If InStr(1, rngCell, str9) > 0 Then
    rngCell = Replace(rngCell.Value, str9, "")
End If
    If InStr(1, rngCell, str10) > 0 Then
    rngCell = Replace(rngCell.Value, str10, "")
End If
    If InStr(1, rngCell, str11) > 0 Then
    rngCell = Replace(rngCell.Value, str11, "")
End If
    If InStr(1, rngCell, str12) > 0 Then
    rngCell = Replace(rngCell.Value, str12, "")
End If
    If InStr(1, rngCell, str13) > 0 Then
    rngCell = Replace(rngCell.Value, str13, "")
End If
    If InStr(1, rngCell, str14) > 0 Then
    rngCell = Replace(rngCell.Value, str14, "")
End If
    If InStr(1, rngCell, str15) > 0 Then
    rngCell = Replace(rngCell.Value, str15, "")
End If
    If InStr(1, rngCell, str16) > 0 Then
    rngCell = Replace(rngCell.Value, str16, "")
End If
    If InStr(1, rngCell, str17) > 0 Then
    rngCell = Replace(rngCell.Value, str17, "")
End If
    If InStr(1, rngCell, str18) > 0 Then
    rngCell = Replace(rngCell.Value, str18, "")
End If
    If InStr(1, rngCell, str19) > 0 Then
    rngCell = Replace(rngCell.Value, str19, "")
End If
    If InStr(1, rngCell, str20) > 0 Then
    rngCell = Replace(rngCell.Value, str20, "")
End If
    If InStr(1, rngCell, str21) > 0 Then
    rngCell = Replace(rngCell.Value, str21, "")
End If
    If InStr(1, rngCell, str22) > 0 Then
    rngCell = Replace(rngCell.Value, str22, "")
End If
    If InStr(1, rngCell, str23) > 0 Then
    rngCell = Replace(rngCell.Value, str23, "")
End If
    If InStr(1, rngCell, str24) > 0 Then
    rngCell = Replace(rngCell.Value, str24, "")
End If
    If InStr(1, rngCell, str25) > 0 Then
    rngCell = Replace(rngCell.Value, str25, "")
End If
    If InStr(1, rngCell, str26) > 0 Then
    rngCell = Replace(rngCell.Value, str26, "")
End If

下一个 rngCell

结束子

Answer 1

尝试

Option Explicit

Sub Findandcut()

    Dim wb As Workbook, ws As Worksheet
    Dim r As Long, level As Integer
    Dim s As String, n As String, ar
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)
    
    For r = 1 To 1000

        s = Left(ws.Cells(r, "A"), 20)
        If Len(s) > 0 Then
            ' split off the paragrah number
            ar = Split(s, " ")
            n = ar(0)
            level = 0

            ' remove brackets
            If InStr(1, n, "[") Then
                level = 5
                n = Replace(n, "[", "")
                n = Replace(n, "]", "")
            ElseIf InStr(1, n, "(") Then
                level = 3
                n = Replace(n, "(", "")
                n = Replace(n, ")", "")
            ElseIf ar(0) Like "*." Then
                level = 1
                n = Replace(n, ".", "")
            End If
            
            If level > 0 Then
                ' check if n not numeric
                If Not IsNumeric(n) Then
                    level = level + 1
                End If
                ' remove number and move to column
                ws.Cells(r, level + 1) = Mid(s, 2 + Len(ar(0)))
                ws.Cells(r, 1) = ""
            End If
            
        End If
    Next

End Sub