Fichiers csv depuis feuilles du classeur

**joponta** · 30/04/2021, 07h54

Bonjour,

Dans le fichier en PJ j'ai des feuilles de mois de l'année.
Je souhaiterais produire un fichier csv qui fait état des feuilles de chaque mois avec les données mensuelles jour par jour, sous cette forme :

matri;nom;prenom;activite;date;DI;POS

est-ce possible ?

merci pour votre aide.

**joponta** · 30/04/2021, 15h48

J'ai essayé avec le code ci-dessous mais je n'obtiens pas ce que je voudrais.
les données sont désordonnées.

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
Sub RegCSV()
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$
Sep = ";"
Worksheets("AVRIL").Select
Set Plage = ActiveSheet.Range("A14:BS" & ActiveSheet.Range("A65000").End(3).Row)
Open "NomEtCheminFichier.csv" For Output As #1
For Each oL In Plage.Rows
 
Tmp = ""
For Each oC In oL.Cells
If oC.Text <> "" Then
Tmp = Tmp & CStr(oC.Text) & Sep
Debug.Print Tmp
End If
Next
Print #1, Tmp
 
Next
Close
End Sub

**fraflt69** · 30/04/2021, 23h28

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
Sub RegCSV()
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$, rows, row, icol As Integer
Dim contenu_ligne
Dim sdate
Sep = ";"
Open "NomEtCheminFichier.csv" For Output As #1
Close #1
 
Worksheets("AVRIL").Select
rows = ActiveSheet.Range("A65000").End(3).row
Open "NomEtCheminFichier.csv" For Append As #1
 
For row = 15 To rows
contenu_ligne = ActiveSheet.Range("A" & row).Text + ";" + ActiveSheet.Range("B" & row).Text + ";" + ActiveSheet.Range("C" & row).Text + ";" + ActiveSheet.Range("D" & row).Text
Set Plage = ActiveSheet.Range("J" & row & ":BS" & row)
 
Tmp = ""
icol = 10
For Each oC In Plage.Cells
sdate = Format((icol - 8) \ 2, "00") & "/" & Format(ActiveSheet.Range("I14").Text, "00") & "/2021"
If oC.Text <> "" Then
Tmp = Tmp & CStr(oC.Text) & Sep
Else
Tmp = Tmp & Sep
End If
If icol Mod 2 = 1 Then
If Tmp <> Sep & Sep Then
  Print #1, contenu_ligne + Sep + sdate + Sep + Tmp
End If
  Tmp = ""
End If
icol = icol + 1
Next
Next row
Close
End Sub

**joponta** · 01/05/2021, 09h37

Bonjour,

Je viens de tester la macro qui fonctionne. Il y a juste un petit problème, le champ date ne comporte pas le mois.
4545;DUPONT;JENA;CADRE;01//2021;DJ;;
4545;DUPONT;JENA;CADRE;03//2021;DJ;;
4545;DUPONT;JENA;CADRE;05//2021;DM;;
4545;DUPONT;JENA;CADRE;06//2021;DM;;
4404;DURAND;FRANCIS;CADRE;03//2021;DAM;;
4404;DURAND;FRANCIS;SEC;02//2021;DM;;
4404;DURAND;FRANCIS;SEC;04//2021;DJ;;
4647;FAIVRE;JEAN;SEC;03//2021;DJ;;
4647;FAIVRE;JEAN;SEC;11//2021;DM;;

Aussi est-il possible d'enregistrer tous les feuilles mois dans ce fichier csv ?

Merci pour votre aide.

**fraflt69** · 01/05/2021, 11h42

4545;DUPONT;JENA;CADRE;01/04/2021;DJ;CADJ;
4545;DUPONT;JENA;CADRE;03/04/2021;DJ;;
4545;DUPONT;JENA;CADRE;05/04/2021;DM;;
4545;DUPONT;JENA;CADRE;06/04/2021;DM;;
4404;DURAND;FRANCIS;CADRE;03/04/2021;DAM;;
4404;DURAND;FRANCIS;SEC;02/04/2021;DM;SECJ;
4404;DURAND;FRANCIS;SEC;04/04/2021;DJ;;
4647;FAIVRE;JEAN;SEC;03/04/2021;DJ;;
4647;FAIVRE;JEAN;SEC;11/04/2021;DM;;
4545;DUPONT;JENA;CADRE;01/05/2021;DJ;CADJ;
4545;DUPONT;JENA;CADRE;03/05/2021;DJ;;
4545;DUPONT;JENA;CADRE;05/05/2021;DM;;
4545;DUPONT;JENA;CADRE;06/05/2021;DM;;
4404;DURAND;FRANCIS;CADRE;03/05/2021;DAM;;
4404;DURAND;FRANCIS;SEC;02/05/2021;DM;SECJ;
4404;DURAND;FRANCIS;SEC;04/05/2021;DJ;;
4647;FAIVRE;JEAN;SEC;03/05/2021;DJ;;
4647;FAIVRE;JEAN;SEC;11/05/2021;DM;;
4545;DUPONT;JENA;CADRE;01/06/2021;DJ;CADJ;
4545;DUPONT;JENA;CADRE;03/06/2021;DJ;;
4545;DUPONT;JENA;CADRE;05/06/2021;DM;;
4545;DUPONT;JENA;CADRE;06/06/2021;DM;;
4404;DURAND;FRANCIS;CADRE;03/06/2021;DAM;;
4404;DURAND;FRANCIS;SEC;02/06/2021;DM;SECJ;
4404;DURAND;FRANCIS;SEC;04/06/2021;DJ;;
4647;FAIVRE;JEAN;SEC;03/06/2021;DJ;;
4647;FAIVRE;JEAN;SEC;11/06/2021;DM;;

**joponta** · 01/05/2021, 13h06

Oui c'est exactement ce que je souhaiterais.
Mais comment avez-vous fait ?
Je ne vois pas le code dans votre message.

**fraflt69** · 02/05/2021, 07h11

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
Function GetWorkSheetIndex(wb, sSheetName As String)
Dim wbFound As Boolean
Dim i As Long
wbFound = False
If (sSheetName <> "") Then
    i = 1
    Do
    If i <= wb.Worksheets.Count Then
     If wb.Worksheets(i).Name = sSheetName Then
      wbFound = True
      Exit Do
     End If
    End If
    i = i + 1
    Loop Until i > wb.Worksheets.Count
End If
If wbFound = True Then GetWorkSheetIndex = i Else GetWorkSheetIndex = -1
End Function
 
 
Sub RegCSV()
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$, rows, row, icol As Integer
Dim contenu_ligne
Dim sdate
Dim mois, cMois, iMois, indMois, sName, iwsh
Dim tab_Mois
tab_Mois = Array("JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE")
Sep = ";"
Open "NomEtCheminFichier.csv" For Output As #1
Close #1
iMois = 0
For Each mois In tab_Mois
iwsh = GetWorkSheetIndex(ActiveWorkbook, CStr(mois))
'If Worksheets(indMois + 1).Name = cMois And Err.Number = 0 Then
If iwsh <> -1 Then
rows = ActiveSheet.Range("A65000").End(3).row
Close #1
Open "NomEtCheminFichier.csv" For Append As #1
 
For row = 15 To rows
contenu_ligne = ActiveSheet.Range("A" & row).Text + ";" + ActiveSheet.Range("B" & row).Text + ";" + ActiveSheet.Range("C" & row).Text + ";" + ActiveSheet.Range("D" & row).Text
Set Plage = ActiveSheet.Range("J" & row & ":BS" & row)
 
Tmp = ""
icol = 10
For Each oC In Plage.Cells
'cMois = ActiveSheet.Range("I14").Text
cMois = CLng(cMois)
sdate = Format((icol - 8) \ 2, "00") & "/" & Format(iwsh + 1, "00") & "/2021"
If oC.Text <> "" Then
Tmp = Tmp & CStr(oC.Text) & Sep
Else
Tmp = Tmp & Sep
End If
If icol Mod 2 = 1 Then
If Tmp <> Sep & Sep Then
  Print #1, contenu_ligne + Sep + sdate + Sep + Tmp
End If
  Tmp = ""
End If
icol = icol + 1
Next
Next row
End If
nextMois:
iMois = iMois + 1
Next mois
Close
End Sub

**joponta** · 02/05/2021, 14h59

Encore merci, mais il me semble qu'il y a un petit souci.
En effet dans le fichier csv les lignes pour DURANT ne sont pas correctes, car il y a un motif CADJ au 1er avril et les lignes me retournent un CADJ sur les 1er mai et 1er juin.
Est-ce que le code écrase le fichier existant ?

Merci pour votre aide

4545	DUPONT	JENA	CADRE	01/04/2021	DJ	CADJ
4545	DUPONT	JENA	CADRE	03/04/2021	DJ
4545	DUPONT	JENA	CADRE	05/04/2021	DM
4545	DUPONT	JENA	CADRE	06/04/2021	DM
4404	DURAND	FRANCIS	CADRE	03/04/2021	DAM
4404	DURAND	FRANCIS	SEC	02/04/2021	DM
4404	DURAND	FRANCIS	SEC	15/04/2021	DJ
4647	FAIVRE	JEAN	SEC	03/04/2021	DJ
4647	FAIVRE	JEAN	SEC	11/04/2021	DM
4545	DUPONT	JENA	CADRE	01/05/2021	DJ	CADJ
4545	DUPONT	JENA	CADRE	03/05/2021	DJ
4545	DUPONT	JENA	CADRE	05/05/2021	DM
4545	DUPONT	JENA	CADRE	06/05/2021	DM
4404	DURAND	FRANCIS	CADRE	03/05/2021	DAM
4404	DURAND	FRANCIS	SEC	02/05/2021	DM
4404	DURAND	FRANCIS	SEC	15/05/2021	DJ
4647	FAIVRE	JEAN	SEC	03/05/2021	DJ
4647	FAIVRE	JEAN	SEC	11/05/2021	DM
4545	DUPONT	JENA	CADRE	01/06/2021	DJ	CADJ
4545	DUPONT	JENA	CADRE	03/06/2021	DJ
4545	DUPONT	JENA	CADRE	05/06/2021	DM
4545	DUPONT	JENA	CADRE	06/06/2021	DM
4404	DURAND	FRANCIS	CADRE	03/06/2021	DAM
4404	DURAND	FRANCIS	SEC	02/06/2021	DM
4404	DURAND	FRANCIS	SEC	15/06/2021	DJ
4647	FAIVRE	JEAN	SEC	03/06/2021	DJ
4647	FAIVRE	JEAN	SEC	11/06/2021	DM

Ci-dessous, le 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
71
72
73
74
Function GetWorkSheetIndex(wb, sSheetName As String)
Dim wbFound As Boolean
Dim i As Long
wbFound = False
If (sSheetName <> "") Then
    i = 1
    Do
    If i <= wb.Worksheets.Count Then
     If wb.Worksheets(i).Name = sSheetName Then
      wbFound = True
      Exit Do
     End If
    End If
    i = i + 1
    Loop Until i > wb.Worksheets.Count
End If
If wbFound = True Then GetWorkSheetIndex = i Else GetWorkSheetIndex = -1
End Function
 
 
Sub RegCSV()
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$, rows, row, icol As Integer
Dim contenu_ligne
Dim sdate
Dim mois, cMois, iMois, indMois, sName, iwsh
Dim tab_Mois
Dim Nomfichier As String
Dim chemin As String
tab_Mois = Array("JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE")
Sep = ";"
Nomfichier = "\activites.csv"
chemin = ThisWorkbook.Path
Open chemin & Nomfichier For Output As #1
Close #1
iMois = 0
For Each mois In tab_Mois
iwsh = GetWorkSheetIndex(ActiveWorkbook, CStr(mois))
'If Worksheets(indMois + 1).Name = cMois And Err.Number = 0 Then
If iwsh <> -1 Then
rows = ActiveSheet.Range("A65000").End(3).row
Close #1
Open chemin & Nomfichier For Append As #1
 
For row = 15 To rows
contenu_ligne = ActiveSheet.Range("A" & row).Text + ";" + ActiveSheet.Range("B" & row).Text + ";" + ActiveSheet.Range("C" & row).Text + ";" + ActiveSheet.Range("D" & row).Text
Set Plage = ActiveSheet.Range("J" & row & ":BS" & row)
 
Tmp = ""
icol = 10
For Each oC In Plage.Cells
'cMois = ActiveSheet.Range("I14").Text
cMois = CLng(cMois)
sdate = Format((icol - 8) \ 2, "00") & "/" & Format(iwsh + 1, "00") & "/2021"
If oC.Text <> "" Then
Tmp = Tmp & CStr(oC.Text) & Sep
Else
Tmp = Tmp & Sep
End If
If icol Mod 2 = 1 Then
If Tmp <> Sep & Sep Then
  Print #1, contenu_ligne + Sep + sdate + Sep + Tmp
  Debug.Print contenu_ligne + Sep + sdate + Sep + Tmp
End If
  Tmp = ""
End If
icol = icol + 1
Next
Next row
End If
nextMois:
iMois = iMois + 1
Next mois
Close
End Sub

**joponta** · 02/05/2021, 17h44

En fait, les dates et noms se dupliquent sur les mois sur le même jour.
Si j'ai une ligne le 01/04, elle se répète sur le 01/05, 01/06...
Comment est-il possible d'y remédier ?

Merci pour votre aide.

**fraflt69** · 02/05/2021, 17h59

Essaye de remplacer Format(iwsh + 1, "00") par Format(cMois , "00") en ligne 49

**joponta** · 02/05/2021, 19h36

J'ai essayé mais ce n'est pas concluant :
4545;DUPONT;JENA;CADRE;01/00/2021;DJ;CADJ;
4545;DUPONT;JENA;CADRE;03/00/2021;DJ;;
4545;DUPONT;JENA;CADRE;05/00/2021;DM;;
4545;DUPONT;JENA;CADRE;06/00/2021;DM;;
4404;DURAND;FRANCIS;CADRE;03/00/2021;DAM;;
4404;DURAND;FRANCIS;SEC;02/00/2021;DM;SECJ;
4404;DURAND;FRANCIS;SEC;15/00/2021;DJ;;
4647;FAIVRE;JEAN;SEC;03/00/2021;DJ;;
4647;FAIVRE;JEAN;SEC;11/00/2021;DM;;
4545;DUPONT;JENA;CADRE;01/00/2021;DJ;CADJ;
4545;DUPONT;JENA;CADRE;03/00/2021;DJ;;
4545;DUPONT;JENA;CADRE;05/00/2021;DM;;
4545;DUPONT;JENA;CADRE;06/00/2021;DM;;
4404;DURAND;FRANCIS;CADRE;03/00/2021;DAM;;
4404;DURAND;FRANCIS;SEC;02/00/2021;DM;SECJ;
4404;DURAND;FRANCIS;SEC;15/00/2021;DJ;;
4647;FAIVRE;JEAN;SEC;03/00/2021;DJ;;
4647;FAIVRE;JEAN;SEC;11/00/2021;DM;;
4545;DUPONT;JENA;CADRE;01/00/2021;DJ;CADJ;
4545;DUPONT;JENA;CADRE;03/00/2021;DJ;;
4545;DUPONT;JENA;CADRE;05/00/2021;DM;;
4545;DUPONT;JENA;CADRE;06/00/2021;DM;;
4404;DURAND;FRANCIS;CADRE;03/00/2021;DAM;;
4404;DURAND;FRANCIS;SEC;02/00/2021;DM;SECJ;
4404;DURAND;FRANCIS;SEC;15/00/2021;DJ;;
4647;FAIVRE;JEAN;SEC;03/00/2021;DJ;;
4647;FAIVRE;JEAN;SEC;11/00/2021;DM;;

**fraflt69** · 03/05/2021, 06h42

Bonjour JoPonta
Excuses, je n'avais pas fait suffisamment attention

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
Function GetWorkSheetIndex(wb, sSheetName As String)
Dim wbFound As Boolean
Dim i As Long
wbFound = False
If (sSheetName <> "") Then
    i = 1
    Do
    If i <= wb.Worksheets.Count Then
     If wb.Worksheets(i).Name = sSheetName Then
      wbFound = True
      Exit Do
     End If
    End If
    i = i + 1
    Loop Until i > wb.Worksheets.Count
End If
If wbFound = True Then GetWorkSheetIndex = i Else GetWorkSheetIndex = -1
End Function
 
 
Sub RegCSV()
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$, rows, row, icol As Integer
Dim contenu_ligne
Dim sdate
Dim ws
Dim mois, cMois, iMois, indMois, sName, iwsh
Dim tab_Mois
tab_Mois = Array("JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE")
Sep = ";"
Open "NomEtCheminFichier.csv" For Output As #1
Close #1
iMois = 0
For Each mois In tab_Mois
iwsh = GetWorkSheetIndex(ActiveWorkbook, CStr(mois))
'If Worksheets(indMois + 1).Name = cMois And Err.Number = 0 Then
If iwsh <> -1 Then
Set ws = ActiveWorkbook.Worksheets(iwsh)
rows = ws.Range("A65000").End(3).row
Close #1
Open "NomEtCheminFichier.csv" For Append As #1
 
For row = 15 To rows
contenu_ligne = ws.Range("A" & row).Text + ";" + ws.Range("B" & row).Text + ";" + ws.Range("C" & row).Text + ";" + ws.Range("D" & row).Text
Set Plage = ws.Range("J" & row & ":BS" & row)
 
Tmp = ""
icol = 10
For Each oC In Plage.Cells
'cMois = ActiveSheet.Range("I14").Text
cMois = CLng(cMois)
sdate = Format((icol - 8) \ 2, "00") & "/" & Format(imois + 1, "00") & "/2021"
If oC.Text <> "" Then
Tmp = Tmp & CStr(oC.Text) & Sep
Else
Tmp = Tmp & Sep
End If
If icol Mod 2 = 1 Then
If Tmp <> Sep & Sep Then
  Print #1, contenu_ligne + Sep + sdate + Sep + Tmp
End If
  Tmp = ""
End If
icol = icol + 1
Next
Next row
End If
nextMois:
iMois = iMois + 1
Next mois
Close
End Sub

**joponta** · 07/05/2021, 18h46

Merci beaucoup

**joponta** · 08/05/2021, 09h10

Bonjour,

J'ai modifier un peu mon fichier et la macro d'export en csv ne fonctionne plus.
Je ne parviens pas à trouver à quel endroit cela bloque.
La macro ne retourne pas d'erreur mais le fichier est vide.
Je vous joins le fichier pour plus de compréhension.

Merci pour votre aide

**joponta** · 08/05/2021, 09h52

J'ai oublié dans les lignes csv comment est-il possible d'ajouter la donnée M ou A ?

**joponta** · 08/05/2021, 10h05

J'ai trouvé pour la mise en place de l'export.
En ce qui concerne la donnée M ou A, J'ai essayé avec ce code

Code :

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

+ ws.Range("J" & row - 1).Text

mais je pense qu'il faut une boucle for

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
Sub RegCSV()
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$, rows, row, icol As Integer
Dim contenu_ligne
Dim sdate
Dim ws
Dim chemin As String
Dim fichier As String
Dim mois, cMois, iMois, indMois, sName, iwsh
Dim tab_Mois
tab_Mois = Array("JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE")
Sep = ";"
Nomfichier = "\activites.csv"
chemin = ThisWorkbook.Path
Open chemin & Nomfichier For Output As #1
Close #1
iMois = 0
For Each mois In tab_Mois
iwsh = GetWorkSheetIndex(ActiveWorkbook, CStr(mois))
 
'If Worksheets(indMois + 1).Name = cMois And Err.Number = 0 Then
If iwsh <> -1 Then
Set ws = ActiveWorkbook.Worksheets(iwsh)
 
rows = ws.Range("A65000").End(3).row
Debug.Print rows
Close #1
Open chemin & Nomfichier For Append As #1
 
For row = 20 To rows
contenu_ligne = ws.Range("A" & row).Text + ";" + ws.Range("B" & row).Text + ";" + ws.Range("C" & row).Text + ";" + ws.Range("D" & row).Text + ";" + ws.Range("J" & row - 1).Text
Set Plage = ws.Range("J" & row & ":BS" & row)
 
Tmp = ""
icol = 10
For Each oC In Plage.Cells
'cMois = ActiveSheet.Range("I14").Text
cMois = CLng(cMois)
 
sdate = Format((icol - 8) \ 2, "00") & "/" & Format(iMois + 1, "00") & "/2021"
 
If oC.Text <> "" Then
Tmp = Tmp & CStr(oC.Text) & Sep
 
Else
Tmp = Tmp & Sep
End If
If icol Mod 2 = 1 Then
If Tmp <> Sep & Sep Then
  Print #1, contenu_ligne + Sep + sdate + Sep + Tmp
  Debug.Print contenu_ligne + Sep + sdate + Sep + Tmp
End If
  Tmp = ""
End If
icol = icol + 1
Next
Next row
End If
nextMois:
iMois = iMois + 1
Next mois
Close
 
End Sub

**joponta** · 08/05/2021, 11h40

J'ai essayé avec le code ci-dessous, mais je n'obtiens que cela :
0;DUPONT;JEAN;Chef de centre;01/05/2021;Faux;1;;
0;DUPONT;JEAN;Chef de centre;01/06/2021;Faux;1;;
0;DUPONT;JEAN;Chef de centre;30/06/2021;;1;1;

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
Function GetWorkSheetIndex(wb, sSheetName As String)
Dim wbFound As Boolean
Dim i As Long
wbFound = False
If (sSheetName <> "") Then
    i = 1
    Do
    If i <= wb.Worksheets.Count Then
     If wb.Worksheets(i).Name = sSheetName Then
      wbFound = True
      Exit Do
     End If
    End If
    i = i + 1
    Loop Until i > wb.Worksheets.Count
End If
If wbFound = True Then GetWorkSheetIndex = i Else GetWorkSheetIndex = -1
End Function
 
 
Sub RegCSV()
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, sval As String, Sep$, rows, row, icol, y As Integer
Dim contenu_ligne
Dim sdate
Dim ws
Dim chemin As String
Dim fichier As String
Dim mois, cMois, iMois, indMois, sName, iwsh
Dim tab_Mois
tab_Mois = Array("JANVIER", "FEVRIER", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE")
Sep = ";"
Nomfichier = "\activites.csv"
chemin = ThisWorkbook.Path
Open chemin & Nomfichier For Output As #1
Close #1
iMois = 0
y = Range("J19").Column
 
For Each mois In tab_Mois
iwsh = GetWorkSheetIndex(ActiveWorkbook, CStr(mois))
 
'If Worksheets(indMois + 1).Name = cMois And Err.Number = 0 Then
If iwsh <> -1 Then
Set ws = ActiveWorkbook.Worksheets(iwsh)
 
rows = ws.Range("A65000").End(3).row
 
Close #1
Open chemin & Nomfichier For Append As #1
 
For row = 20 To rows
 
contenu_ligne = ws.Range("A" & row).Text + ";" + ws.Range("B" & row).Text + ";" + ws.Range("C" & row).Text + ";" + ws.Range("D" & row).Text
Set Plage = ws.Range("J" & row & ":BS" & row)
 
Tmp = ""
icol = 10
For Each oC In Plage.Cells
'cMois = ActiveSheet.Range("I14").Text
cMois = CLng(cMois)
 
sdate = Format((icol - 8) \ 2, "00") & "/" & Format(iMois + 1, "00") & "/2021"
 
sval = Cells(icol, 19).Value
'Debug.Print sval
If oC.Text <> "" Then
Tmp = Tmp & CStr(oC.Text) & Sep
 
Else
Tmp = Tmp & Sep
End If
If icol Mod 2 = 1 Then
If Tmp <> Sep & Sep Then
  Print #1, contenu_ligne + Sep + sdate + Sep + sval + Sep + Tmp
  Debug.Print contenu_ligne + Sep + sdate + Sep + sval + Sep + Tmp
End If
  Tmp = ""
End If
icol = icol + 1
Next
 
Next row
End If
nextMois:
iMois = iMois + 1
Next mois
Close
 
End Sub

Fichiers csv depuis feuilles du classeur

Macros et VBA Excel

Discussions similaires

Partager

Partager