Macro vba et chemin des dossiers

Version imprimable

20/01/2011, 13h40
safouunette

Macro vba et chemin des dossiers

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?
20/01/2011, 13h46
Godzestla

Citation:

quelqu'un a une idée?

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

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

Code:

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

bonjour,

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

donc

Code:

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

20/01/2011, 14h24
kiki29

Salut,peut-être en plaçant

Code:

ChDir "D:"

avant le

Code:

"D:\Nouveau dossier\Archive Feuille"
20/01/2011, 14h25
safouunette

Merci beaucoup mayekeul,
je devais juste placer

Code:

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

par

Code:

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

Essaies ce code

Code:

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

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

Code:

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