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

在Excel工作表上，列A有成千上万的sorting和格式如下的行：

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来做。

然后，这样做，经常会有文件夹中有这么多封闭的文件，列表超出了一个屏幕高度，所以没有指示可见文件属于哪个文件夹。 我想提取顶部滚动屏幕的最后一个文件夹的path，也许把它放到一个var滚动更新，然后我把它放在一个文本框，并将其作为参考。

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

• 谢谢

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上创build你想要的工作表，而不会混淆Sheet1。 由于我远离插入/删除，这种方法是快速的（ 对于超过3500行约1.5秒 ）。 如果您的行不是合法的文件path，则可能需要添加错误检查。

怎么运行的：

• 将列转储到varray中来处理
• 使用“\”上的InStrRev查找文件夹path，并将dict的path添加为键和文件作为项目
• 如果path存在，我将新文件追加到最后一个，并用“，”分隔
• 在工作表2上，我通过字典进行循环，并以所需的格式转储数据。

码：

 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