besoin d'aide à corrigé une macro

**simo1616** · 06/06/2022, 14h36

bonjour,

je dois importé des données à partir d'une autre feuille "base de données" qui est à la base des réponse à un formulaire d'inscription, et à l'aide d'un ami j'ai réussi à établir le liens mais maintenant j'arrives pas car j'ai changer les positions dans le formulaire à une question que j'ai oublié du coup la macro ne marche plus, pouvez vous m'aidé svp je ne vois pas où dois je changé

merci beaucoup

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
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
 
Sub ImporterQuestionnaires()
 
Dim WbSource As Workbook
Dim WbDest As Workbook
Dim TabSource() As Variant
Dim TabDispo() As Variant
Dim NbColDispo As Long
 
Dim TabMontage() As Variant
Dim NbColMontage As Long
Dim DuréeTournoi As Long
 
Dim NomFeuilleToImport As String
Dim PremierJourTournoi As String
Dim PremierJourMontage As String
 
Dim FirstColTournoi As Long
Dim FirstColMontage As Long
 
 
DuréeTournoi = 8 '8 jours à partir du samedi 16
DuréeMontage = 9
PremierJourTournoi = "Samedi 16"
NbColDispo = 18
 
PremierJourMontage = "Lundi 11"
NbColMontage = 20
 
'NomFeuilleToImport = "Formulaire inscription Bénévole"
 
Set WbDest = ActiveWorkbook 'on définit le classeur "Benevoles" comme le classeur de destination
 
FileToOpen = Application.GetOpenFilename() 'on demande le fichier des réponses
If FileToOpen <> False Then
    'NomFeuilleToImport = Replace(Split(FileToOpen, "\")(UBound(Split(FileToOpen, "\"))), ".csv", "")
    Workbooks.Open FileToOpen 'on ouvre le fichier
    NomFeuilleToImport = ActiveSheet.Name 'on récupère le nom de la feuille
    Set WbSource = ActiveWorkbook
    If Not FeuilleExiste(NomFeuilleToImport) Then 'inutile car la feuille cherchée est celle active dans le fichier ouvert==> remplacer ce test par autre chose pour etre sur que le fichier ouvert est bien un fichier de réponse??
        MsgBox ("la feuille """ & NomFeuilleToImport & """ n'existe pas dans le fichier à importer" & Chr(10) & "Veuillez vérifier le fichier et recommencez")
        Exit Sub
    End If
 
 
    With WbSource.Sheets(NomFeuilleToImport) 'on récupère les données dans un tablo
        fin = .UsedRange.Rows.Count 'dernière ligne de données
        TabSource = .Range("A1:AF" & fin).Value 'on met les colonnes A à AF das le tableau
        Set trouve = .Rows(1).Find("Planning du Tournoi [" & PremierJourTournoi & "]") 'on cherche la position du premier jour de tournoi
        If Not trouve Is Nothing Then
            FirstColTournoi = trouve.Column
        Else
            MsgBox ("Attention, le formulaire semble ne pas avoir la bonne structure: Pas de date de tournoi le " & PremierJourTournoi)
            Exit Sub
        End If
 
        Set trouve = .Rows(1).Find("montage [" & PremierJourMontage, lookat:=xlPart)  'on cherche la position du premier jour de montage démontage
        If Not trouve Is Nothing Then
            FirstColMontage = trouve.Column
        Else
            MsgBox ("Attention, le formulaire semble ne pas avoir la bonne structure: Pas de jour de démontage le " & PremierJourMontage)
            Exit Sub
        End If
    End With
    WbSource.Close False 'on peut fermer la source
End If
 
With Sheets("BDD GENERALE") 'dans la feuille BDD GENERALE
    .Cells.Clear 'on efface tout
    .Range("A1").Resize(UBound(TabSource, 1), UBound(TabSource, 2)) = TabSource 'on colle le tableau source dans la feuille
End With
 
'*****************************************************Remplissage de l'onglet "Disponibilités"**********************************************************************
ReDim TabDispo(1 To UBound(TabSource, 1) - 1, 1 To NbColDispo) 'on définit la taille du tablo Dispo
For i = LBound(TabSource, 1) + 1 To UBound(TabSource, 1) 'pour chaque ligne du tablo source, on remplit le tablo dispo avec les bonnes infos prises au bon endroit
    TabDispo(i - 1, 1) = i - 1
    TabDispo(i - 1, 2) = TabSource(i, 3) & " " & TabSource(i, 4)
    For j = FirstColTournoi To FirstColTournoi + DuréeTournoi - 1
        ColP1 = 2 * (j - (FirstColTournoi - 1)) + 1
        ColP2 = 2 * (j - (FirstColTournoi - 1)) + 2
        TabDispo(i - 1, ColP1) = IIf(InStr(1, TabSource(i - 1, j), "P1") <> 0, "x", "")
        TabDispo(i - 1, ColP2) = IIf(InStr(1, TabSource(i - 1, j), "P2") <> 0, "x", "")
    Next j
 
Next i
AjoutSup = MsgBox("Souhaitez vous Ajouter (OUI) ou Remplacer (NON) les bénévoles déjà présents?", vbYesNoCancel)
If AjoutSup = vbCancel Then Exit Sub
 
With WbDest.Sheets("DISPONIBILITES") 'on place le résultat dans la feuille dispo
 
    If AjoutSup = vbNo Then .Range("B7").CurrentRegion.Offset(2, 0).ClearContents 'on efface les données déjà présentes
    fin = WorksheetFunction.Max(7, .Range("B" & .Rows.Count).End(xlUp).Row + 1)
    .Range("B" & fin).Resize(UBound(TabDispo, 1), UBound(TabDispo, 2)) = TabDispo
    If AjoutSup = vbYes Then
        .Range("B" & fin - 2 & ":B" & fin - 1).AutoFill Destination:=.Range("B" & fin - 2 & ":B" & fin + UBound(TabDispo, 1) - 1)
    End If
   ' Disponibilités 'on appelle la macro pour recalculer les totaux
End With
'**********************************************************************************************************************************************************************
 
'*****************************************************Remplissage de l'onglet "MONTAGE DEMONTAGE"**********************************************************************
ReDim TabMontage(1 To UBound(TabSource, 1) - 1, 1 To NbColMontage) 'on définit la taille du tablo Dispo
For i = LBound(TabSource, 1) + 1 To UBound(TabSource, 1) 'pour chaque ligne du tablo source, on remplit le tablo dispo avec les bonnes infos prises au bon endroit
    TabMontage(i - 1, 1) = i - 1
    TabMontage(i - 1, 2) = TabSource(i, 3) & " " & TabSource(i, 4)
    For j = FirstColMontage To FirstColMontage + DuréeMontage - 1
        ColP1 = 2 * (j - (FirstColMontage - 1)) + 1
        ColP2 = 2 * (j - (FirstColMontage - 1)) + 2
        TabMontage(i - 1, ColP1) = IIf(InStr(1, TabSource(i - 1, j), "Matin") <> 0, "x", "")
        TabMontage(i - 1, ColP2) = IIf(InStr(1, TabSource(i - 1, j), "midi") <> 0, "x", "")
    Next j
 
Next i
AjoutSup = MsgBox("Souhaitez vous Ajouter (OUI) ou Remplacer (NON) les bénévoles déjà présents?", vbYesNoCancel)
If AjoutSup = vbCancel Then Exit Sub
 
With WbDest.Sheets("MONTAGE DEMONTAGE") 'on place le résultat dans la feuille dispo
 
    If AjoutSup = vbNo Then .Range("B7").CurrentRegion.Offset(2, 0).ClearContents 'on efface les données déjà présentes
    fin = WorksheetFunction.Max(7, .Range("B" & .Rows.Count).End(xlUp).Row + 1)
    .Range("B" & fin).Resize(UBound(TabMontage, 1), UBound(TabMontage, 2)) = TabMontage
    If AjoutSup = vbYes Then
        .Range("B" & fin - 2 & ":B" & fin - 1).AutoFill Destination:=.Range("B" & fin - 2 & ":B" & fin + UBound(TabMontage, 1) - 1)
    End If
    Disponibilités 'on appelle la macro pour recalculer les totaux
End With
'**********************************************************************************************************************************************************************
 
End Sub
 
Function FeuilleExiste(NomFeuille As String) As Boolean
FeuilleExiste = False
For Each ws In ActiveWorkbook.Sheets
    If ws.Name = NomFeuille Then
        FeuilleExiste = True
        Exit Function
    End If
Next ws
End Function
 
Sub Disponibilités()
Dim TabDispo() As Variant
Dim TabMontage() As Variant
 
'******************************************************************Disponibilités******************************************************************
With Sheets("DISPONIBILITES") 'dans la feuille Disponibilités
    fin = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabDispo = .Range("B5:U" & fin).Value 'on place le tableau de la feuille dans un tableau vba
    For i = LBound(TabDispo, 1) + 2 To UBound(TabDispo, 1) 'pour chaque ligne (hors entete)
        totalperiode = 0 'mise à 0 du compteur
        totalJour = 0 'mise à 0 du compteur
        For j = LBound(TabDispo, 2) + 2 To UBound(TabDispo, 2) - 2 'pour chaque colonne:  2eme colonnes et deux dernières colonnes exclues
            totalperiode = totalperiode + IIf(TabDispo(i, j) <> "", 1, 0) 'on incrémente le compteur si il y a quelque chose dans la cellule
 
            If j Mod 2 = 1 Then ' on est sur une colonne Periode1
                totalJour = totalJour + IIf(TabDispo(i, j) <> "", 1, 0)
            Else
                If TabDispo(i, j - 1) = "x" Then
                    'déjà compté
                Else
                    totalJour = totalJour + IIf(TabDispo(i, j) <> "", 1, 0)
                End If
            End If
        Next j
        TabDispo(i, UBound(TabDispo, 2) - 1) = totalperiode 'on met le resultat dans l'avant dernière colonne
        TabDispo(i, UBound(TabDispo, 2)) = totalJour 'on met le resultat dans la dernière colonne
    Next i
    .Range("B5:U" & fin) = TabDispo 'on remet les résultats dans la feuille
End With
 
'******************************************************************MONTAGE DEMONTAGE****************************************************************
With Sheets("MONTAGE DEMONTAGE") 'dans la feuille Disponibilités
    fin = .Range("B" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne B
    TabMontage = .Range("B5:W" & fin).Value 'on place le tableau de la feuille dans un tableau vba
    For i = LBound(TabMontage, 1) + 2 To UBound(TabMontage, 1) 'pour chaque ligne (hors entete)
        totalperiode = 0 'mise à 0 du compteur
        totalJour = 0 'mise à 0 du compteur
        For j = LBound(TabMontage, 2) + 2 To UBound(TabMontage, 2) - 2 'pour chaque colonne:  2eme colonnes et deux dernières colonnes exclues
            totalperiode = totalperiode + IIf(TabMontage(i, j) <> "", 1, 0) 'on incrémente le compteur si il y a quelque chose dans la cellule
 
            If j Mod 2 = 1 Then ' on est sur une colonne Periode1
                totalJour = totalJour + IIf(TabMontage(i, j) <> "", 1, 0)
            Else
                If TabMontage(i, j - 1) = "x" Then
                    'déjà compté
                Else
                    totalJour = totalJour + IIf(TabMontage(i, j) <> "", 1, 0)
                End If
            End If
        Next j
        TabMontage(i, UBound(TabMontage, 2) - 1) = totalperiode 'on met le resultat dans l'avant dernière colonne
        TabMontage(i, UBound(TabMontage, 2)) = totalJour 'on met le resultat dans la dernière colonne
    Next i
    .Range("B5:W" & fin) = TabMontage 'on remet les résultats dans la feuille
End With
 
 
For Each ws In ActiveWorkbook.Sheets
    If ws.Name Like "*P1" Or ws.Name Like "*P2" Then
 
        jour = UCase(Trim(Split(ws.Name, "P")(0)))
        Periode = Replace(ws.Range("D1"), "PERIODE ", "")
        'on cherche quelle est la colonne du tablo dispo correspondante
        For j = LBound(TabDispo, 2) + 2 To UBound(TabDispo, 2) - 2
            If UCase(Format(TabDispo(1, j), "dddd dd")) = jour Then
                ColRecherche = j + Periode - 1
                Exit For
            End If
        Next j
        With ws
            'on commence par effacer les tablo de dispo
            .Range("U3").CurrentRegion.Offset(1, 0).ClearContents
            .Range("U4") = 1
            formule = "=if((sumproduct(($D$5:$P$10=V4)*1)+sumproduct(($D$16:$S$21=V4)*1)+sumproduct(($D$27:$J$32=V4)*1)>=1),""OUI"",""NON"")"
            .Range("W4").Formula = formule
 
            For i = LBound(TabDispo, 1) + 2 To UBound(TabDispo, 1)
                If TabDispo(i, ColRecherche) = "x" Then
                    .Range("V" & .Rows.Count).End(xlUp).Offset(1, 0) = TabDispo(i, 2)
                    .Range("U" & .Rows.Count).End(xlUp).Offset(1, 0) = .Range("U" & .Rows.Count).End(xlUp) + 1
                End If
            Next i
            NbBene = .Range("V" & .Rows.Count).End(xlUp).Row
            .Range("W4:W" & NbBene).FillDown 'Destination:=.Range("W4:W" & NbBene)
        End With
    End If
Next ws
 
End Sub

test planning.xlsm

**Philippe Tulliez** · 06/06/2022, 15h38

Bonjour,
Vous n'avez pas indiqué le numéro de votre version Excel mais si c'est pour importer vos données et les transformer, je vous conseille d'utiliser PowerQuery

**simo1616** · 06/06/2022, 16h05

MERCI POUR VOTRE REPONSE

EXCEL 19

POUR QUERY JE NE SAIS PAS COMMENT FAIRE ENCORE
IMPORTER DES DONNEES ??

FAUT QUE JE SAISIE SUR LA MACRO DOIS CHERCHER FEUILLE BDD GENERALE DANS LE TABLEAU ET EXCUTER LA SUITE POUR ALIMENTER LES AUTRES TABLEAU CHOSE QUE JE NE SAIS PAS FAIRE

MERCI POUR VOTRE AIDE

besoin d'aide à corrigé une macro

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager