从Word到Excel的多级列表

Question

我需要的结果是在MS Word中的多级列表在excel中跨列传播，然后将多级列表指示器移动到自己的列中。现在，我的代码删除了多级列表指示器。我有一个解决方案，但它不适用于从a到z的多级列表指示器，因为句子的末尾有一个字母和句号，代码是删除句子的最后一个字母和句号。我需要代码来选择左边的字母句点或数字句点，字符串的开头。此外，我无法将方括号“”作为字符串读取，因此我必须声明每个匹配项。有没有办法将"[]“标识为字符串的一部分？此代码将多级列表复制到正确的列中。我需要它只移动内容，如果数字或字母。例如: 1.或a.或(1)或(a)或1或a在字符串的开头。这是我用来根据多级列表指示器移动单元格内容的代码。我使用的第二个代码是在将多级列表移到列后将其删除。最终，我想将多级列表指标移动到他们自己的列中，在他们的内容的同一行上。最终，我希望将多级(例如: 1.或a.或(1)或(a)或1或a)移到该级别内容旁边的列中。word中的多级列表

Word list copy and pasted into excel

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

excel desired 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