Question

On an Excel sheet, Col A has many thousands of rows that are sorted and formatted like this:

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

and I’d like to convert to this:

C:\\Folder1\Folder2\
fileA
fileB

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

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

etc.

I’d prefer to do it with VBA if possible.

Then, with that done, there will frequently be folders that have so many enclosed files that the list extends beyond one screen height, and so there’s no indication of which folder the visible files belong to. I’d like to extract the path of the last folder that scrolled off screen at the top, and maybe put it into a var that gets updated with the scroll, then I’ll put that on a TextBox and leave it out for reference.

Ok, that last part looks hard, but full marks if you can help me get the first part done.

• Thanks

Answer 1

This should work for you. Since there is no event to capture when the user scrolls, the folder “header row” is repeated every 20 rows if necessary.

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