Cellen opnieuw formatteren met mappaden om de bestandsnamen op een aparte rij te plaatsen

Op een Excel-werkblad heeft Col A vele duizenden rijen die op deze manier zijn gesorteerd en opgemaakt:

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

en ik zou hier graag van willen converteren:

C:\\Folder1\Folder2\
fileA
fileB

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

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

enz.

Ik zou het liefst doen met VBA indien mogelijk.

Als dat klaar is, zullen er vaak mappen zijn met zoveel ingesloten bestanden dat de lijst meer dan één schermhoogte beslaat, en dus is er geen indicatie van tot welke map de zichtbare bestanden behoren. Ik zou graag het pad van de laatste map eruit halen die bovenaan het scherm is geschoven, en misschien in een var plaatsen die wordt bijgewerkt met de schuif, dan plaats ik die op een TextBox en laat ik hem achterwege voor referentie.

Ok, dat laatste deel ziet er moeilijk uit, maar volledige punten als je me kunt helpen om het eerste deel af te krijgen.

  • Thanks
1

2 antwoord

Dit zou voor u moeten werken. Aangezien er geen gebeurtenis is om vast te leggen wanneer de gebruiker schuift, wordt de map "header rij" elke 20 rijen indien nodig herhaald.

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
0
toegevoegd
Bedankt Rachel, dat werkt goed. Ik heb het een beetje opgeschud door de kleur en het gewicht van het lettertype voor de rijen te wijzigen met Mappen, maar anders werkt het wel.
toegevoegd de auteur Roy, de bron

Hier leest u hoe u het eerste deel met een woordenboekobject en InStrRev doet. Het maakt het blad dat u wilt op Sheet2 en knoeit niet met Sheet1. Omdat ik er niet bij ben om in te voegen/te verwijderen, is deze methode snel ( ongeveer 1,5 seconden voor 3500 of meer rijen ). Mogelijk wilt u foutcontrole toevoegen voor het geval u rijen hebt die geen legale bestandspaden zijn.

Hoe het werkt:

  • Kolom dum in een varray om met
  • te werken
  • Zoek mappad met behulp van InStrRev op "\" en voeg pad toe aan dict als sleutel en bestand als item
  • Als het pad bestaat, voeg ik het nieuwe bestand bij de laatste en scheid ik het met ","
  • Op blad 2 doorloop ik het dictaat en dump ik de gegevens in het gewenste formaat.

Code:

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
0
toegevoegd
Issun, ik probeerde Rachel's oplossing eerst, en het werkte zo goed dat ik niet verder ging. Maar bedankt voor het antwoord.
toegevoegd de auteur Roy, de bron