VBA gegevens worksheet kopieren, worksheet bewerken, gegevens terugplaatsen

[Matjes]

Onderstaande VBA code maakt mappen en submappen met namen zoals deze zijn ingegeven op worksheet folders. Om de submappen aan te maken wijzigt de code de namen van de submappen door de naamgeving van de parent mappen ervoor te zetten (maken van het pad).

Nu wil ik graag voor dat dit gebeurd de worksheet tijdelijk opslaan om wanneer de mappen en submappen zijn aangemaakt deze gegevens weer terug te plaatsen. Ik heb dit al geprobeerd met een range en copy alleen zonder het gewenste resultaat.

Gewenste resultaat, volgorde:

1) maak kopie gegevens worksheet
2) voer onderstaande code uit
3) zet gegevens worksheet terug uit punt 1

Weet iemand een goede oplossing?

Option Explicit

Sub createFolders()
Dim fpath As String
Dim i, xc As Integer
Dim rng As Range

On Error Resume Next

'Set rng = Worksheets("Folders").Range("A1:Z100")
    
Worksheets("Folders").Range("A1:Z100").Copy


    For i = 1 To ActiveSheet.UsedRange.Rows.Count
        xc = Range("XFD" & i).End(xlToLeft).Column
        
        If xc = 1 Then
            fpath = Cells(i, xc).Value
        Else
            fpath = Cells(Cells(i, xc - 1).End(xlUp).Row, xc - 1).Value & "/" & Cells(i, xc).Value
            Cells(i, xc).Value = fpath
        End If
        
        MkDir ("C:\users\Admin\Desktop\" & fpath)
        If Err.Number <> 0 Then
            Err.Clear
        End If
    Next
    
    
'Worksheets("Folders").Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Cells.Value = rng.Cells.Value
    
Worksheets("Folders").Range("A1").PasteSpecial Paste:=xlPasteValues

End Sub

 

[VenA]

Waarom? Er wijzigt toch niets op het werkblad.

 

[Matjes]

Jawel, in deze regel wordt de naam van de map vervangen door het voorvoegen van de parent map:

Cells(i, xc).Value = fpath

 

[VenA]

Waar sla je die waarde niet op in een variabele? Plaats anders even het bestandje.

 

[snb]

1 regel VBA volstaat:

Sub M_snb()
    CreateObject("shell.application").Namespace("C:").NewFolder "users\Admin\Desktop\sub1\gebruiker2"
End Sub

 

[Matjes]

Ik heb even een voorbeeld bestandje gepost om het wat duidelijker te maken. Na het runnen van de code door op de knop 'Maak mappen' te klikken worden de cellen van de submappen gewijzigd omdat de parent mappen er voor worden gevoegd om het path volledig te maken. Dat is prima voor het maken van de submappen echter wil ik de naamgeving van de submappen daarna weer origineel hebben voor een volgend gebruik. Deze wil ik daarom eerst opslaan en later terugplaatsen.

Hopelijk is het zo wat duidelijker

Bekijk bijlage MaakMappen.xlsm

 

[snb]

Private Sub CommandButton1_Click()
    sn = Cells(1).CurrentRegion
    
    With CreateObject("shell.application").Namespace("C:")
        For j = 1 To UBound(sn)
           .NewFolder Join(Application.Index(sn, j), "\")
        Next
    End With
End Sub

 

[Matjes]

Snb bedankt voor de alternatieve code :thumb: stukje korter Nu iets meer typewerk op de worksheet maar zo kun je ook alle mappen en submappen ook mooi in een lijst weergeven, filteren en sorteren.

 

[edmoor]

Vergeet ook dat On Error Resume Next statement.
Dat dient alleen in zeer specifieke gevallen te worden gebruikt en niet zomaar als eerste opdrachtregel in een stuk code.

 

[snb]

Het aanmaken van een groot aantal directories met subdirectories duidt veelal op een gebrek aan inzicht in wat een echte database inhoudt.
In plaats van te splitsen (zij het in werkbladen, bestanden en/of directories) dienen gelijksoortige gegevens bij voorkeur in 1 werkblad in 1 bestand te worden opgenomen.

 

[Matjes]

vind de onderstaande code voor het aanmaken van de path nog wel wat lastig.

Private Sub CommandButton1_Click()
    sn = Cells(1).CurrentRegion
    With CreateObject("shell.application").Namespace("C:")
        For j = 1 To UBound(sn)
           .NewFolder Join(Application.Index(sn, j), "\")
        Next
    End With
End Sub

sn = variabele type range?

Graag zou ik alvorens het path wordt aangemaakt deze nog door de onderstaande functie 'removeSpecial' willen laten controleren / aanpassen op speciale karakters. Hoe kan ik deze functie in bovenstaande functie inpassen?

Function removeSpecial(sInput As String) As String
    Dim sSpecialChars As String
    Dim i As Long
    sSpecialChars = "\/:*??""?<>|.&@# (_+`?~);-+=^$!,'"
    For i = 1 To Len(sSpecialChars)
        sInput = Replace$(sInput, Mid$(sSpecialChars, i, 1), "")

    Next
    sInput = UCase(sInput)
    removeSpecial = sInput
End Function

Alvast dank voor het meedenken

 

[snb]

met F8 kun je gang van zaken per regel volgen.

Die controle lijkt me onzin als je zelf de gegevens voor de namen met de hand invoert en niet-gewenste tekens vermijdt

 

[Matjes]

Bedankt voor de F8 tip. Maar hoe zou je de Function integreren? Even los van als het zinvol of onzin is maar ik wil er ook graag wat van kunnen leren

 

[cow18]

dan doet snb die moeite om daar netjes een \ op de correcte plaats tussen te krijgen en dan zal die toch worden verwijderd met die UDF :evil:

 .NewFolder removeSpecial(Join(Application.Index(sn, j), "\"))

Deze code was eerder om emailadressen op speciale karakters te controleren dacht ik.
Daarnaast heeft snb gelijk, terwijl je toch handmatig aan het ingeven bent, dan controleer je toch gelijkertijd.

 

[Matjes]

Bedankt voor de adviezen en het aangepaste voorbeeld. Weer wat opgestoken