VBA makrosu ile klasörler ve alt klasörler oluşturma

Her sütunda ne olduğuna bağlı olarak klasörler ve alt klasörler oluşturmak için oluşturduğum bir elektronik tabloyu kullanmak istiyorum.

İlk sütun üst seviye, ikinci sütun sonraki seviye aşağı (alt klasör) vb.

    A                 B                   C                   D
1   TOP FOLDER 1      Sub Folder 1.1      Sub Folder 1.2      Sub Folder 1.3
2   TOP FOLDER 2      Sub Folder 2.1      Sub Folder 2.2      Sub Folder 2.3
3   TOP FOLDER 3      Sub Folder 3.1      Sub Folder 3.2      Sub Folder 3.3

Zaten başka bir program denedim ve bu klasörler yaptı ama hepsini bir klasöre koy! Alt klasörlere ihtiyacım var, ancak bir sorunun klasörleri ayırmak olabileceğini düşünüyorum, işte bir örnek:

Alt klasörleri üst klasörlerine ayırmanın problemli olabileceğini düşünüyorum çünkü aynı sütunlardalar ...

Bu VBA ile bir klasör yapısı oluşturur. Kısa ve güzel

Sub CreateFolderStructure()
    Dim objRow as Range, objCell as Range, strFolders as String

    For Each objRow In ActiveSheet.UsedRange.Rows
        strFolders = "C:\myRootFolder"            
        For Each objCell In objRow.Cells
            strFolders = strFolders & "\" & objCell
        Next            
        Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))
    Next    
End Sub

^{Hata işleme yok!}

Bu ne yapar

1. Etkin Excel sayfanızın her kullanılan satırında dolaşın
2. Yeni klasörlerimizin yaratılacağı kök klasörü ayarlayın. Her döngüde yapılmalı
3. Geçerli satırdaki tüm kullanılan hücrelerin arasında dolaş
4. Kök klasörü ters eğik çizgi ve yeni alt klasörle birleştirin.
   Biz böyle bir şey elde edene kadar, bu satırdaki her alt klasör için
   "C:\myRootFolder\TOP FOLDER 1\SUB FOLDER 1.1\SUB FOLDER 1.2\SUB FOLDER 1.3"
5. Şimdi sihir geliyor. Yaparız değil VBA'ları kullan mkdir işlevi.
   Bunun yerine kullanıyoruz Shell(cmd /c md) tek bir komutla birkaç klasör oluşturabilir. Ayrıca bir klasör zaten mevcutsa hata üretmez. Böyle güzel bir komut

Bazı notlar

• Klasör adlarında bu karakterlerden kaçının: © ® " - & ' ^ ( ) @
• Boş Excel hücreleri sorun değil. MD komutu gibi dizeleri idare edebilir C:\root\\subfolder iki ardışık ters eğik çizgi ile
• Klasör adlarındaki boşluklar sorun değil çünkü tüm yapıyı iki tırnak işareti ile sarıyoruz chr(34) )

Sub MkDirs()

    Const RootPath = "C:\your\path"
    Dim rng As Range

    Set rng = Selection

    For Each rw In rng.Rows
        ChDir RootPath
        For Each cl In rw.Cells
            If cl <> "" Then
                MkDir cl
                ChDir cl
            End If
        Next
    Next 
End Sub

İşte kodda tanımlamak yerine bir kök dosya seçmenize izin veren daha iyi bir cevap:

Sub FolderCreator()

    Dim objRow As Range, objCell As Range, strFolders As String, rootFolder As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        ' show the file picker dialog box
        If .Show <> 0 Then
            rootFolder = .SelectedItems(1)
              End If
    End With

    For Each objRow In ActiveSheet.UsedRange.Rows
        strFolders = rootFolder
        For Each objCell In objRow.Cells
            strFolders = strFolders & "\" & objCell
        Next
        Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))
    Next

End Sub