Macro vba et chemin des dossiers

**safouunette** · 20/01/2011, 13h40

Bonjour,
Je cherche à faire une macro qui me permet d'enregistrer mon travail d'une feuille excel dans d'autres dossiers! ça marche nickel quand j'ai défini le dossier ou je veux enregistrer sur le bureau
Dossier = "C:\Documents and Settings\Personnel\Bureau\Archive Feuille\"

mais si je le définie dans un autre endroit (ici "D:\Nouveau dossier\Archive Feuille")
J'ai remarqué en excecutant pas à pas la macro que le fichier que je veux créer se crée sur le bueau mais je ne le trouve jamais dans le dossier souhaité!! c'est bizar!
Je ne comprend pas pourquoi! quelqu'un a une idée?

**Godzestla** · 20/01/2011, 13h46

quelqu'un a une idée?

Bonjour,
Sans voir ton code.....pas vraiment.

**safouunette** · 20/01/2011, 13h53

Oui

cette macro marche bien mais moi je veux
Dossier = "D:\Nouveau dossier\Archive Feuille\

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
Sub Archiver()
Dim wbk As Workbook
Dim aSh As Worksheet, Sh As Worksheet
Dim iLRA%, iLRN%
Dim Dossier As String, Fichier As String, Feuille As String
 'quand je definie le dossier dans le D: ca ne marche pas 
 'Dossier = "D:\Nouveau dossier\Archive Feuille\"
 
Dossier = "C:\Documents and Settings\Personnel\Bureau\Archive Feuille Immob\"
Application.ScreenUpdating = False
Set aSh = ThisWorkbook.Worksheets(2)
 
If IsDate(aSh.Range("A2").Value) Then
    Fichier = Dossier & Year(aSh.Range("A2").Value) & ".xls"
    Feuille = MonthName(Month(aSh.Range("A2").Value))
    On Error Resume Next
    Set wbk = Workbooks.Open(Fichier)
    On Error GoTo 0
    If wbk Is Nothing Then
        Set wbk = Workbooks.Add(1)
        Set Sh = wbk.Worksheets(1)
        Sh.Name = Feuille
    Else
        On Error Resume Next
        Set Sh = Worksheets(Feuille)
        On Error GoTo 0
        If Sh Is Nothing Then
            Set Sh = wbk.Worksheets.Add(after:=wbk.Sheets(wbk.Sheets.Count))
            Sh.Name = Feuille
        End If
    End If
 
    iLRA = Sh.Cells(65535, 3).End(xlUp).Row
    iLRN = aSh.Cells(65535, 3).End(xlUp).Row
    If Sh.Range("A1") = "" Then
    aSh.Range("A1:F" & iLRN).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A" & iLRA)
    Else
    aSh.Range("A2:F" & iLRN).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A" & iLRA + 1)
    End If
 
    With Sh
    Set Plage = .Range(.[A1], .[F65536].End(xlUp))
    End With
 
        With Plage
 
        For i = 2 To .Rows.Count - 1
            For j = .Rows.Count To i + 1 Step -1
                    For k = 1 To 6
                        If .Rows(i).Cells(k) = .Rows(j).Cells(k) Then
                            l = l + 1
                        End If
                    Next k
                    If l = 6 Then
                        With .Rows(j)
                            .EntireRow.Delete
                        End With
                    End If
                l = 0
            Next j
        Next i
        End With
 
        With Sh
            Columns("A:A").Select
            Selection.ColumnWidth = 18
            Columns("B:B").Select
            Selection.ColumnWidth = 10.71
            Columns("C:C").Select
            Range("C2").Activate
            Selection.ColumnWidth = 8
            Columns("D:D").Select
            Range("D2").Activate
            Selection.ColumnWidth = 3
            Columns("E:E").Select
            Selection.ColumnWidth = 51
            Columns("F:F").Select
            Selection.ColumnWidth = 10.71
            Range("A1").Select
        End With
    ChDir Dossier
    Application.DisplayAlerts = False
    wbk.SaveAs Year(aSh.Range("A2").Value) & ".xls"
    Application.DisplayAlerts = True
    wbk.Close
    Set wbk = Nothing
    Set Sh = Nothing
End If
Set aSh = Nothing
End Sub

**mayekeul** · 20/01/2011, 14h01

bonjour,

tu ne défini pas le répertoire de sauvegarde

donc

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
 
Sub Archiver()
Dim wbk As Workbook
Dim aSh As Worksheet, Sh As Worksheet
Dim iLRA%, iLRN%
Dim Dossier As String, Fichier As String, Feuille As String,DossierSauve as string
 'quand je definie le dossier dans le D: ca ne marche pas 
DossierSauve = "D:\Nouveau dossier\Archive Feuille\"
 
Dossier = "C:\Documents and Settings\Personnel\Bureau\Archive Feuille Immob\"
Application.ScreenUpdating = False
Set aSh = ThisWorkbook.Worksheets(2)
 
If IsDate(aSh.Range("A2").Value) Then
    Fichier = Dossier & Year(aSh.Range("A2").Value) & ".xls"
    Feuille = MonthName(Month(aSh.Range("A2").Value))
    On Error Resume Next
    Set wbk = Workbooks.Open(Fichier)
    On Error GoTo 0
    If wbk Is Nothing Then
        Set wbk = Workbooks.Add(1)
        Set Sh = wbk.Worksheets(1)
        Sh.Name = Feuille
    Else
        On Error Resume Next
        Set Sh = Worksheets(Feuille)
        On Error GoTo 0
        If Sh Is Nothing Then
            Set Sh = wbk.Worksheets.Add(after:=wbk.Sheets(wbk.Sheets.Count))
            Sh.Name = Feuille
        End If
    End If
 
    iLRA = Sh.Cells(65535, 3).End(xlUp).Row
    iLRN = aSh.Cells(65535, 3).End(xlUp).Row
    If Sh.Range("A1") = "" Then
    aSh.Range("A1:F" & iLRN).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A" & iLRA)
    Else
    aSh.Range("A2:F" & iLRN).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A" & iLRA + 1)
    End If
 
    With Sh
    Set Plage = .Range(.[A1], .[F65536].End(xlUp))
    End With
 
        With Plage
 
        For i = 2 To .Rows.Count - 1
            For j = .Rows.Count To i + 1 Step -1
                    For k = 1 To 6
                        If .Rows(i).Cells(k) = .Rows(j).Cells(k) Then
                            l = l + 1
                        End If
                    Next k
                    If l = 6 Then
                        With .Rows(j)
                            .EntireRow.Delete
                        End With
                    End If
                l = 0
            Next j
        Next i
        End With
 
        With Sh
            Columns("A:A").Select
            Selection.ColumnWidth = 18
            Columns("B:B").Select
            Selection.ColumnWidth = 10.71
            Columns("C:C").Select
            Range("C2").Activate
            Selection.ColumnWidth = 8
            Columns("D:D").Select
            Range("D2").Activate
            Selection.ColumnWidth = 3
            Columns("E:E").Select
            Selection.ColumnWidth = 51
            Columns("F:F").Select
            Selection.ColumnWidth = 10.71
            Range("A1").Select
        End With
    ChDir Dossier
    Application.DisplayAlerts = False
    wbk.SaveAs DossierSauve & Year(aSh.Range("A2").Value) & ".xls"
    Application.DisplayAlerts = True
    wbk.Close
    Set wbk = Nothing
    Set Sh = Nothing
End If
Set aSh = Nothing
End Sub

**kiki29** · 20/01/2011, 14h24

Salut,peut-être en plaçant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ChDir "D:"

avant le

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

"D:\Nouveau dossier\Archive Feuille"

**safouunette** · 20/01/2011, 14h25

Merci beaucoup mayekeul,
je devais juste placer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

wbk.SaveAs Year(aSh.Range("A2").Value) & ".xls"

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

wbk.SaveAs Dossier & Year(aSh.Range("A2").Value) & ".xls"

tu m'as donné une idée!!
sans définir le répertoir de sauvgarde car mon "dossier" est celui de sauvgarde
thanksss

**mercatog** · 20/01/2011, 14h51

Essaies ce code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
Sub Archiver()
Dim wbk As Workbook
Dim aSh As Worksheet, Sh As Worksheet
Dim iLRA As Long, iLRN As Long, i As Long, j As Long
Dim Dossier As String, Fichier As String, Feuille As String, DossierNew As String
Dim k As Byte, s As Byte
 
DossierNew = "D:\Nouveau dossier\Archive Feuille\"
Dossier = "C:\Documents and Settings\Personnel\Bureau\Archive Feuille Immob\"
Application.ScreenUpdating = False
Set aSh = ThisWorkbook.Worksheets(2)
If IsDate(aSh.Range("A2").Value) Then
    Fichier = Dossier & Year(aSh.Range("A2").Value) & ".xls"
    Feuille = MonthName(Month(aSh.Range("A2").Value))
    On Error Resume Next
    Set wbk = Workbooks.Open(Fichier)
    On Error GoTo 0
    If wbk Is Nothing Then
        Set wbk = Workbooks.Add(1)
        Set Sh = wbk.Worksheets(1)
        Sh.Name = Feuille
    Else
        On Error Resume Next
        Set Sh = Worksheets(Feuille)
        On Error GoTo 0
        If Sh Is Nothing Then
            Set Sh = wbk.Worksheets.Add(After:=wbk.Sheets(wbk.Sheets.Count))
            Sh.Name = Feuille
        End If
    End If
 
    iLRA = Sh.Cells(Sh.Rows.Count, 3).End(xlUp).Row
    iLRN = aSh.Cells(aSh.Rows.Count, 3).End(xlUp).Row
    If Sh.Range("A1") = "" Then
        aSh.Range("A1:F" & iLRN).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A" & iLRA)
    Else
        aSh.Range("A2:F" & iLRN).SpecialCells(xlCellTypeVisible).Copy Sh.Range("A" & iLRA + 1)
    End If
    With Sh
        iLRA = .Cells(.Rows.Count, 3).End(xlUp).Row
        For i = 2 To iLRA - 1
            For j = iLRA To i + 1 Step -1
                For k = 1 To 6
                    If .Cells(i, k) = .Cells(j, k) Then
                        s = s + 1
                    Else
                        Exit For
                    End If
                Next k
                If s = 6 Then .Rows(j).Delete
                s = 0
            Next j
        Next i
        .Columns("A:A").ColumnWidth = 18
        .Columns("B:B").ColumnWidth = 10.71
        .Columns("C:C").ColumnWidth = 8
        .Columns("D:D").ColumnWidth = 3
        .Columns("E:E").ColumnWidth = 51
        .Columns("F:F").ColumnWidth = 10.71
    End With
    ChDir DossierNew
    Application.DisplayAlerts = False
    wbk.SaveAs Year(aSh.Range("A2").Value) & ".xls"
    Application.DisplayAlerts = True
    wbk.Close
    Set wbk = Nothing
    Set Sh = Nothing
End If
Set aSh = Nothing
End Sub

**kiki29** · 20/01/2011, 16h19

Re,j'ai supposé que le dossier existait sinon utiliser en l'adaptant à ton contexte :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
 
' Pour valeur retournée dans Rep
' Voir http://msdn.microsoft.com/en-us/library/bb762131(VS.85).aspx
' et   http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Sub
 
Sub Test()
Dim sDossier As String
    sDossier = "D:\repA\repB\repC\repD\repE\repF"
    CreationDossier sDossier
End Sub

Macro vba et chemin des dossiers [XL-2003]

Macros et VBA Excel

Discussions similaires

Partager

Partager