Probleem met het maken van DIR.

[edmoor]

Ik heb jouw code gekopieerd en bij mij worden die mappen prima aangemaakt.
Wat er met ActiveWorkbook.SaveAs precies aan de hand is kan ik zo niet zeggen.

 

[Atwist]

Voor alle zekerheid heb ik de strings een vaste invoer gegeven.

sHmap = "greppel" 'Sheets("lijst").Range("B4")
sSmap = "HZ001" 'Sheets("lijst").Range("C7")
slijst = Sheets("lijst").Range("Z1")

Maar dat haalt ook niets uit.

 

[edmoor]

Behalve slijst

 

[Atwist]

Bij toeval zag ik dat de mappen direct op de T schijf staan ipv T:\ontwerpen.

 

[edmoor]

Vreemd, bij mij maakt hij keurig het pad aan.

 

[Atwist]

Behalve slijst

Klopt maar ik wilde eerst de dirs. aanmaken.

Ik denk dat het SaveAs opgelost is als het aanmaken van de mappen goed gaat.

 

[Atwist]

Dit is mijn code

Dim sHmap As String
Dim sSmap As String
Dim slijst As String
Dim mPath() As String
Dim Teller As Integer

sHmap = "greppel" 'Sheets("lijst").Range("B4")
sSmap = "HZ001" 'Sheets("lijst").Range("C7")
slijst = Sheets("lijst").Range("Z1")

 mPath = Split("Ontwerpen\" & sHmap & "\" & sSmap, "\")

    ChDrive "T"
    ChDir "\"
    For Teller = 0 To UBound(mPath)
        If Dir(mPath(Teller), vbDirectory) = "" Then
            MkDir mPath(Teller)
            ChDir mPath(Teller)
        End If
    Next


'If Dir("T:\Ontwerpen\" & sHmap & "\" & sSmap, vbDirectory) = "" Then
 '   MkDir "T:\Ontwerpen\" & sHmap & "\" & sSmap
'End If
'If Dir("T:\Ontwerpen\" & sHmap & "\" & sSmap, vbDirectory) = "" Then MkDir "T:\Ontwerpen\" & sHmap & "\" & sSmap
FullFileName = "T:\Ontwerpen\" & sHmap & "\" & sSmap & "\" & slijst
While Len(Dir(FullFileName & "-" & i & ".xlsx")) > 0
i = i + 1
Wend
'ChDir "T:\Ontwerpen\" & sHmap & "\" & sSmap

Sheets("lijst").Copy
 ActiveWorkbook.SaveAs Filename:=FullFileName & "-" & i & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  ActiveWindow.Close

 

[Atwist]

Ik heb in het direct venster gekeken bij
?mPath
Geeft niets aan en krijg compileer fout

 

[edmoor]

mPath is een array en die vraag je als volgt uit:
?mPath(0)

En zo kun je in plaats van 0 ook 1 en 2 gebruiken.
2 is in dit geval het hoogste element in de array.

 

[Atwist]

Ook dan krijg ik een compileer fout

"Sub of Functie niet gedefinieerd"

 

[edmoor]

Ook dat kan alleen als de functie loopt en de array gevuld is.
Ik heb overigens vanavond verder geen tijd meer dus zul je alleen verder moeten stoeien.

 

[Atwist]

Geen probleem

Ik dankje voor al je hulp

En een fijne avond nog

 

[Atwist]

Heb het probleem opgelost.:d

Edmoor zei:

Kennelijk mag je vanuit VBA niet het hele pad in 1x aanmaken. Daar gaat het fout.
Ik heb het opgelost door de mappen 1 voor 1 aan te maken.

:thumb::thumb:

Denk niet dat het de juist manier van programmeren is maar het werk wel.
Het ziet er nu als volgt uit.

Private Sub CommandButton14_Click()
Dim sHmap As String
Dim sSmap As String
Dim slijst As String

sHmap = Sheets("lijst").Range("B4")
sSmap = Sheets("lijst").Range("C7")
slijst = Sheets("lijst").Range("Z1")
 
   
[COLOR="blue"]If Dir("T:\Ontwerpen\" & sHmap, vbDirectory) = Empty Then MkDir "T:\Ontwerpen\" & sHmap
ChDir "T:\Ontwerpen\" & sHmap
If Dir(sSmap, vbDirectory) = Empty Then MkDir sSmap
ChDir sSmap[/COLOR]
         
FullFileName = "T:\Ontwerpen\" & sHmap & "\" & sSmap & "\" & slijst
While Len(Dir(FullFileName & "-" & i & ".xlsx")) > 0
i = i + 1
Wend
ChDir "T:\Ontwerpen\" & sHmap & "\" & sSmap

Sheets("lijst").Copy
 ActiveWorkbook.SaveAs Filename:=FullFileName & "-" & i & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
  ActiveWindow.Close

Ga mij nu bezig houden met een volgend probleem.