Discussion :

[colbubu]

bonjour a tous,

en regroupant les infos du net j ai réussi a obtenir un code qui marche.... mais a moitié

voila mon petit probleme j ai un dossier avec pluieurs fichiers asc et plusieurs classeurs xlsx je souhaite prendre les asc dans excel puis les découper en tableau les copier et les coller dans le classeur excel correspondant

cependant dans le code que j ai il saute parfois un classeur et apres le dernier classeur le code FichS=Dir ne marche pas

je vous envoie une partie de mopn code pour que vous puissiez en juger

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
Sub format()
'
' format Macro
'
 
'dimensionner les variables
 
Dim objworkbooksource As Workbook
Dim objworkbookcible  As Workbook
Dim Repertoire        As String
Dim FichS             As String
Dim FichD             As String
 
Repertoire = "C:\Users\Homer II\Documents\"
FichS = Dir(Repertoire & "*.asc")
FichD = Dir(Repertoire & "*.xlsx")
Do While FichS <> ""
     Workbooks.Open Repertoire & FichS
 
 
 
'mettre les données .csv en tableau xl
 
Set objworkbooksource = ActiveWorkbook
 
 
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Range("1:2,4:4,6:8").Select
    Range("A6").Activate
    Selection.Delete Shift:=xlUp
 
'copier les données dans le tableau correspondant
 
Set objworkbookcible = Application.Workbooks.Open(Repertoire & FichD)
 
    objworkbooksource.Activate
    Range("A3", Cells(3, 1).End(xlDown).End(xlToRight)).Copy
 
    objworkbookcible.Activate
    Sheets("Values").Activate
    Range("D3").PasteSpecial
    Application.CutCopyMode = False
    objworkbooksource.Close savechanges:=False
 
 
 'sauvergarder les données sous un nouvel emplacement
 
 
        objworkbookcible.SaveAs Replace(FichD, "xlsx", "xls"), FileFormat:=xlExcel8
        objworkbookcible.Close
 
 
        FichS = Dir
        FichD = Dir
    Loop
 
End Sub

merci pour votre aide

bon j ai cru comprendre que le probleme vient du = Dir

en fait el fait d en avoir deux ne me permet pas de les diférencier via vba est ce que quelqu'un sait comment je peut faire pour les différencier

sachant que le = Dir me permet de passer au classeur suivant

j'ai pensé a enregistrer tous les dir dans un tableau mais est ce que je suis obligé de créer un nouveau classeur excel pour faire ce tableau ou bien existe il un façon de le créer virtuellement

[colbubu]

bon j ai résolu mes problemes en créant une nouvelle feuille avec les noms des dossiers dedans je fait tourner la macro pour ceux que ça interesse

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
 
Sub format()
'
' format Macro
'
 
'dimensionner les variables
 
Dim objworkbooksource As Workbook
Dim objworkbookcible  As Workbook
Dim moment            As Workbook
Dim Repertoire        As String
Dim FichS             As String
Dim FichD             As String
Dim i                 As Integer
 
 
 
Repertoire = "C:\Users\Homer II\Documents\"
 
FichD = Dir(Repertoire & "*.xlsx")
Workbooks.Add (1)
Set moment = ActiveWorkbook
 
i = 1
Do While FichD <> ""
 
    Sheets("Feuil1").Range("A" & i).Value = FichD
    i = i + 1
    FichD = Dir
Loop
 
i = 1
 
FichS = Dir(Repertoire & "*.asc")
 
Do While FichS <> ""
     Workbooks.Open Repertoire & FichS
 
 
 
'mettre les données .csv en tableau xl
 
Set objworkbooksource = ActiveWorkbook
 
 
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False
    Columns("A:B").Select
    Selection.Delete Shift:=xlToLeft
    Range("1:2,4:4,6:8").Select
    Range("A6").Activate
    Selection.Delete Shift:=xlUp
 
'copier les données dans le tableau correspondant
 
moment.Activate
 
 
Set objworkbookcible = Application.Workbooks.Open(Repertoire & Range("A" & i).Value)
 
    objworkbooksource.Activate
    Range("A3", Cells(3, 1).End(xlDown).End(xlToRight)).Copy
 
    objworkbookcible.Activate
    Sheets("Values").Activate
    Range("D3").PasteSpecial
    Application.CutCopyMode = False
    objworkbooksource.Close savechanges:=False
    'sauvergarder les données sous un nouvel emplacement
 
        moment.Activate
 
        objworkbookcible.SaveAs Replace(Range("A" & i).Value, "xlsx", "xls"), FileFormat:=xlExcel8
        objworkbookcible.Close
 
        i = i + 1
        FichS = Dir
    Loop
 
    moment.Close (False)
 
End Sub

voila j'espere que ça vous aide

a bientot sur le fofo