Question

在Excel工作表中，Col A有数千行按照以下方式排序和格式化：

C:\\Folder1\Folder2\fileA
C:\\Folder1\Folder2\fileB
C:\\Folder1\Folder2\Folder3\fileC
C:\\Folder1\Folder2\Folder3\fileD
C:\\Folder1\Folder2\Folder3\fileE
C:\\Folder1\Folder2\Folder4\Folder5\fileF
C:\\Folder1\Folder2\Folder4\Folder5\fileG

我想转换成这个：

C:\\Folder1\Folder2\
fileA
fileB

C:\\Folder1\Folder2\Folder3\
fileC
fileD
fileE

C:\\Folder1\Folder2\Folder4\Folder5\
fileF
fileG

等

如果可能，我更愿意使用VBA。

然后，完成此操作后，通常会有一些文件夹包含如此多的封闭文件，列表超出一个屏幕高度，因此没有迹象表明可见文件属于哪个文件夹。我想提取在顶部滚动屏幕的最后一个文件夹的路径，并且可能将其放入一个用滚动更新的var中，然后我将它放在TextBox上并将其留作参考。

好的，最后一部分看起来很难，但是如果你可以帮我完成第一部分，那就是满分。

感谢

Answer 1

这对你有用。由于用户滚动时没有要捕获的事件，因此必要时每20行重复一次“标题行”文件夹。

Sub ReformatCells()
    Dim lRow As Long
    Dim lRowStart As Long
    Dim sPath As String
    Dim sFolderPrev As String
    Dim sFolderCur As String
    Const MAX_ROW_SECTION As Long = 20

    With ActiveSheet
        lRow = 0                  ' row before first row to format
        sPath = "start"           ' any non-zero-length string
        sFolderPrev = CStr(Timer) ' value guarenteed not to match
        Do While Len(sPath) > 0
            lRow = lRow + 1
            sPath = .Cells(lRow, 1).Value
            sFolderCur = GetFolder(sPath)
            If sFolderCur <> sFolderPrev Then
                ' new folder, so insert a blank row and "header row"
                .Rows(lRow).Insert
                .Rows(lRow).Insert
                lRow = lRow + 1
                lRowStart = lRow
                .Cells(lRow, 1) = sFolderCur
                sFolderPrev = sFolderCur
                lRow = lRow + 1
                .Cells(lRow, 1) = Mid$(sPath, Len(sFolderPrev) + 1)
            Else
                If lRow - lRowStart >= MAX_ROW_SECTION Then
                    ' repeat folder header
                    .Rows(lRow).Insert
                    .Cells(lRow, 1) = sFolderPrev & " (cont)"
                    lRowStart = lRow
                    lRow = lRow + 1
                End If
                ' just trim off the folder
                .Cells(lRow, 1) = Mid$(sPath, Len(sFolderPrev) + 1)
            End If
        Loop
    End With
End Sub
Function GetFolder(sPath As String) As String
    Dim iPos As Integer
    iPos = InStrRev(sPath, "\")
    If iPos > 0 Then
        GetFolder = Left$(sPath, iPos)
    Else
        GetFolder = sPath
    End If
End Function

Answer 2

以下是如何使用字典对象和InStrRev完成第一部分。它将在Sheet2上创建您想要的工作表，而不是与Sheet1混乱。由于我远离插入/删除，这种方法很快（3500+行 约1.5秒）。如果您的行不是合法文件路径，则可能需要添加错误检查。

工作原理：

将列转储到varray中以使用

使用“\”上的InStrRev查找文件夹路径，并将路径添加为dict作为键，将文件添加为项目

如果路径存在，我会将新文件追加到最后一个文件中并单独添加“，”

在表2中，我遍历dict并以所需格式转储数据。

代码：

Sub test() Application.ScreenUpdating = False Dim dict As Object Set dict = CreateObject("scripting.dictionary") Dim i As Long, j As Long, pathEnd As Long Dim varray As Variant, folderName As Variant Dim path As String, fileName As String, files() As String With Sheets(1) varray = .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).Value End With For i = 1 To UBound(varray, 1) pathEnd = InStrRev(varray(i, 1), "\") path = Left$(varray(i, 1), pathEnd) fileName = Mid$(varray(i, 1), pathEnd + 1) If Not dict.exists(path) Then dict.Add path, fileName Else dict.Item(path) = dict.Item(path) & ", " & fileName End If Next i = 1 With Sheets(2) For Each folderName In dict .Range("A" & i).Value = folderName files = Split(dict.Item(folderName), ", ") For j = 0 To UBound(files) .Range("A" & i).Offset(j + 1, 0).Value = files(j) Next i = i + UBound(files) + 3 Next End With Application.ScreenUpdating = True End Sub

使用文件夹路径重新格式化单元格以将文件名放在单独的行上

2 个答案: