simo161616
XLDnaute Junior
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
[modération: pièce jointe contrevenant au RGPD, supprimée]
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
VB:
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[modération: pièce jointe contrevenant au RGPD, supprimée]
Dernière modification par un modérateur:
