Fichiers csv depuis feuilles du classeur

Version imprimable

30/04/2021, 07h54
joponta

1 pièce(s) jointe(s)

Fichiers csv depuis feuilles du classeur

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.

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:

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

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
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

01/05/2021, 09h37
joponta

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.
01/05/2021, 11h42
fraflt69

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;;
01/05/2021, 13h06
joponta

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

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
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

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:

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

02/05/2021, 17h44
joponta

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.
02/05/2021, 17h59
fraflt69

Essaye de remplacer Format(iwsh + 1, "00") par Format(cMois , "00") en ligne 49
02/05/2021, 19h36
joponta

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;;

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

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
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

07/05/2021, 18h46
joponta

Merci beaucoup
08/05/2021, 09h10
joponta

1 pièce(s) jointe(s)

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
08/05/2021, 09h52
joponta

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

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:

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

mais je pense qu'il faut une boucle for

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
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

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:

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

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