Excel 宏删除包含可变文本的行

Question

这是我第一次发帖。

我正在尝试在 Excel 2016 中找到一种方法来清理文件夹列表，以便我只有父文件夹。

我有一个电子表格，其中 A 列是文件夹列表，包括它们的子文件夹。像这样：[fyi - 每行还有其他列，但它们与本示例无关]

\\server\share\root\subfolder1\
\\server\share\root\subfolder1\sub-subfolderA\
\\server\share\root\subfolder1\sub-subfolderB\
\\server\share\root\subfolder1\sub-subfolderC\
\\server\share\root\subfolder2\
\\server\share\root\subfolder2\other-subfolderA\
\\server\share\root\subfolder2\other-subfolderB\
\\server22\share\root\subfolder3\ham_sandwich\
\\server22\share\root\subfolder3\ham_sandwich\yet-another-subfolderA\
\\server22\share\root\subfolder3\and-another-subfolderA\
\\server22\share\root\subfolder3\and-another-subfolderB\

大约有 2500 行包含不同长度的文件夹，我的最终目标是只得到每个“集合”的顶级文件夹。例如：

\\server\share\root\subfolder1\
\\server\share\root\subfolder2\
\\server22\share\root\subfolder3\ham_sandwich\
\\server22\share\root\subfolder3\and-another-subfolderA\
\\server22\share\root\subfolder3\and-another-subfolderB\

我对此的逻辑如下（如果我忽略了任何内容，请纠正我）：

See if the string in A1 is contained within the string in A2.
  If A2 contains the string, delete row 2.
  If it doesn't, move down to compare A2 with A3. [since we know A1 is now the only cell containing that top folder]
Rinse-and-repeat until the last populated row is reached.

我的问题是找出代码。我在网上看到各种关于搜索指定文本的代码 sn-ps，但没有任何使用变量的代码。我最初是在玩弄 IsNumber 和 Search 的公式组合，但它需要固定的文本来搜索，这会随着宏的进行而改变。

有人可以为我指出正确的方向吗？

Answer 1

假设顶级文件夹总是在子文件夹之前列出：

k = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = k - 1 To 1 Step -1
    For j = k To i + 1 Step -1
        If InStr(Range("A" & j), Range("A" & i)) > 0 Then
            Rows(j).Delete
            k = k - 1
        End If
    Next j
Next i

Answer 2

如果您的列表很长，使用 VBA 数组处理列表会更快，而不是重复的工作表读/写。

宏假定数据已按您显示的方式排序。如果没有，请先添加一个例程对其进行排序。

我们遍历每个项目，并检查是否可以找到之前存储的项目。基于此，我们确定是否将结果存储在我们的字典中。然后我们将其输出到工作表。

您可以在代码中查看在哪里可以改变要处理的范围以及您想要的结果。

'Set reference to Microsoft Scripting Runtime
Option Explicit
Sub cleanList()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim dList As Dictionary
    Dim V, I As Long

Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 2) 'results in column B

'Assume data starts in A1
'Read into variant array for speed of processing
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'collect results
Set dList = New Dictionary
    dList.CompareMode = TextCompare

For Each V In vSrc
    If dList.Count = 0 Then
        dList.Add Key:=V, Item:=V
    ElseIf InStr(V, dList.Keys(dList.Count - 1)) = 0 Then
            dList.Add Key:=V, Item:=V
    End If
Next V

'create results array
ReDim vRes(1 To dList.Count, 1 To 1)
I = 0
For Each V In dList
    I = I + 1
    vRes(I, 1) = V
Next V

'set results range
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1))

'write results to worksheet
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub

Answer 3

一种可能的解决方案（基于您的数据集）：

Sub test()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim rng As Range: Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp))
    Dim cl As Range, x As Variant, cntr&: cntr = 0

    dic.Add cntr, rng.Cells(1).Value2: cntr = cntr + 1
    For Each cl In rng
        If Not LCase(cl.Value2) Like LCase(dic(cntr - 1)) & "*" Then
            dic.Add cntr, cl.Value2: cntr = cntr + 1
        End If
    Next cl

    For Each x In dic
        Debug.Print dic(x)
    Next x
End Sub

下面的测试：