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 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236
| Dim nom As String
Dim MonMM As String
Dim MonYYYY As String
Dim MonYY As String
MonYY = Mid(Worksheets(1).Range("B2").Value, 7, 2)
MonYYYY = Mid(Worksheets(1).Range("B2").Value, 5, 4)
MonMM = Mid(Worksheets(1).Range("B2").Value, 1, 3)
Select Case MonMM
Case "JAN"
MonMM = "01"
Case "FEV"
MonMM = "02"
Case "MAR"
MonMM = "03"
Case "AVR"
MonMM = "04"
Case "MAI"
MonMM = "05"
Case "JUI"
MonMM = "06"
Case "JUL"
MonMM = "07"
Case "AOU"
MonMM = "08"
Case "SEP"
MonMM = "09"
Case "OCT"
MonMM = "10"
Case "NOV"
MonMM = "11"
Case Else
MonMM = "12"
End Select
Application.ScreenUpdating = False
Worksheets(1).Select
' test si 1re page est vide
If WorksheetFunction.CountA(ActiveSheet.UsedRange) = 0 And ActiveSheet.Shapes.Count = 0 Then
MsgBox "La feuille est vide", vbInformation, "Jane prog. creation page CSV"
Else
'si 1re page n'est pas vide executer ce qui suit
'définition du nom de la page 2 et remplissage des 2 lignes de tête de tableau
Dim EDPEDK As String
EDPEDK = ActiveWorkbook.Name
MsgBox EDPEDK, vbInformation, "contenu variable"
SendKeys String:="{enter}", Wait:=False
nom = "VENPR767" & MonYY & MonMM & "00"
'si la feuille klapotek existe la supprimer
'ajoute la feuille klapotek
Sheets.Add After:=Worksheets(1)
Worksheets(2).Name = nom
Worksheets(2).Cells(2, 1).Value = "Année/Mois"
Worksheets(2).Cells(2, 2).Value = "Code Diffuseur"
Worksheets(2).Cells(2, 3).Value = "Groupe Editeur"
Worksheets(2).Cells(2, 4).Value = "Code Editeur"
Worksheets(2).Cells(2, 5).Value = "Code Collection"
Worksheets(2).Cells(2, 6).Value = "Collection"
Worksheets(2).Cells(2, 7).Value = "Article"
Worksheets(2).Cells(1, 8).Value = "1:France"
Worksheets(2).Cells(2, 8).Value = "2:Export"
Worksheets(2).Cells(2, 9).Value = "Auteur"
Worksheets(2).Cells(2, 10).Value = "Titre"
Worksheets(2).Cells(1, 11).Value = "Exemplaires"
Worksheets(2).Cells(2, 11).Value = "Office"
Worksheets(2).Cells(1, 12).Value = "Autres"
Worksheets(2).Cells(2, 12).Value = "Vendus"
Worksheets(2).Cells(2, 13).Value = "Retours"
Worksheets(2).Cells(2, 14).Value = "Ventes Net"
Worksheets(2).Cells(1, 15).Value = "Nb Lig"
Worksheets(2).Cells(2, 15).Value = "Ventes"
Worksheets(2).Cells(1, 16).Value = "Nb Lig"
Worksheets(2).Cells(2, 16).Value = "Retours"
Worksheets(2).Cells(1, 17).Value = "Nb Lig"
Worksheets(2).Cells(2, 17).Value = "Rea."
Worksheets(2).Cells(1, 18).Value = "Nb Cli"
Worksheets(2).Cells(2, 18).Value = "Ventes"
Worksheets(2).Cells(1, 19).Value = "Nb Cli"
Worksheets(2).Cells(2, 19).Value = "Retours"
Worksheets(2).Cells(2, 20).Value = "P.U."
Worksheets(2).Cells(2, 21).Value = "Remise"
Worksheets(2).Cells(2, 22).Value = "Brut HT"
Worksheets(2).Cells(2, 23).Value = "Net Brut HT"
Worksheets(2).Cells(2, 24).Value = "CodeEAN13"
'calcul du nombre de lignes du tableau
Dim lngLigne As Long
Worksheets(1).Select
lngLigne = 2
Do While Range("D" & lngLigne).Value <> ""
lngLigne = lngLigne + 1
Loop
'supprimer le dernier tour
lngLigne = lngLigne - 1
Range("D2:D" & lngLigne).Copy
Worksheets(2).Select
Range("X3").Select
ActiveSheet.Paste
'Copie de la colonne B en A
Worksheets(1).Select
Range("B2:B" & lngLigne).Copy
Worksheets(2).Select
Range("A3").Select
ActiveSheet.Paste
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
'Changement colonne A avec code AAAAMM (ex : 201807)
Dim cel As Range
For Each cel In Selection
cel = MonYYYY & MonMM
Next cel
'Copie de la colonne D en D (code EDP 767)
Range("D3").Select
ActiveSheet.Paste
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
For Each cel In Selection
cel = 767
Next cel
'Copie de la colonne I en H plus changement France /Etranger en 00001/00002
Worksheets(1).Select
Range("I2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Worksheets(2).Select
Range("H3").Select
ActiveSheet.Paste
Range("H3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).NumberFormat = "00000"
For Each cel In Selection
If cel = "France" Then
cel = CStr("00001")
Else
cel = CStr("00002")
End If
Next cel
'Copie de la colonne J en K
Worksheets(1).Select
Range("J2:J" & lngLigne).Copy
Worksheets(2).Select
Range("K3").Select
ActiveSheet.Paste
'Copie de la colonne K en L
Worksheets(1).Select
Range("K2:K" & lngLigne).Copy
Worksheets(2).Select
Range("L3").Select
ActiveSheet.Paste
'Copie de la colonne L en M
Worksheets(1).Select
Range("L2:L" & lngLigne).Copy
Worksheets(2).Select
Range("M3").Select
ActiveSheet.Paste
'Copie de la colonne M en N
Worksheets(1).Select
Range("M2:M" & lngLigne).Copy
Worksheets(2).Select
Range("N3").Select
ActiveSheet.Paste
'créer CSV
Dim chemincsv As String
chemincsv = nom & ".csv"
'chemin du fichier
Dim chemin As String, fichiercsv As String
chemin = ThisWorkbook.Path
'tester si les dossiers existent sinon les créer
If Dir(chemin & "\KLAPOTEK\", 16) = "" Then
MkDir (chemin & "\KLAPOTEK\")
End If
If Dir(chemin & "\KLAPOTEK\" & MonYYYY & MonMM, 16) = "" Then
MkDir (chemin & "\KLAPOTEK\" & MonYYYY & MonMM)
End If
'créer classeur KLAPOTEK
fichierKlapotek = chemin & "\KLAPOTEK\" & MonYYYY & MonMM & "\" & nom
Worksheets(2).Copy
'there is now a new active workbook
Workbook.Add
With ActiveWorkbook
'save it
.SaveAs Filename:=fichierKlapotek, FileFormat:=xlOpenXMLWorkbook
'optionally close it
.Close savechanges:=False
End With
'chemin et nom du fichier csv
fichiercsv = chemin & "\KLAPOTEK\" & MonYYYY & MonMM & "\" & nom & ".csv"
MsgBox fichiercsv, vbInformation, "Jane chemin du fichier .csv"
Worksheets(2).Select
'Créer fichier.csv
Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$
Sep = ";"
Set Plage = ActiveSheet.Range("A1:X" & ActiveSheet.Range("X65000").End(3).Row)
Open fichiercsv For Output As #1
For Each oL In Plage.Rows
Tmp = ""
For Each oC In oL.Cells
Tmp = Tmp & CStr(oC.Text) & Sep
Next
Print #1, Tmp
Next
Close
End If 'fin des actions si Worksheets(1) n'est pas vide
Application.ScreenUpdating = True |
Partager