与文件夹路径把文件名在一个单独的行

Question

在Excel表单格式化细胞，柱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。由于我从插入/删除远离，该方法是快速的（约1.5秒为3500+行）。如果您有不合法文件路径的行，则可能需要添加错误检查。

它是如何工作的：

• 转储列到VARRAY对“\”使用InStrRev与
• 查找文件夹路径工作和路径添加到字典的关键和文件作为项目
• 如果路径存在，我通过字典新文件追加到最后一个和独立与“”
• 在片材2，I环和以需要的格式转储数据。

代码：

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