XL 2019 modifications macro svp

simo161616 · 6 Juin 2022

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

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]

sylvanu · 6 Juin 2022

Bonjour Simo,
Remettez nous une PJ anonymisée comme demandé par le modérateur, car sans cette pièce il n'y a peu de chances qu'on puisse vous aider.
Et dites nous aussi quelle modif vous avez apporté, ça aiguillera.

simo161616 · 6 Juin 2022

Bonjour,
tout ces informations sont fictives j'ai pris sur un site générateur d'identités

https://fr.fakenamegenerator.com/gen-male-fr-fr.php

donc ca ne craint rien
je vous remets la même si ca dérange pas les modérateurs

j'ai trouvé un moyen manuel pour importé les donnés directement par POWER QUERRY depuis un fichier mais je ne sais pas comment automatisé le reste, pour activer le reste de la macro pour remplir les autre feuilles "DISPONIBILITE"; "MONTAGE DEMONTAGE" "PLANNING .........ETC

merci pour votre aides

Bernard_XLD · 6 Juin 2022

simo161616 à dit:
je vous remets la même si ca dérange pas les modérateurs

Bonjour

non, cela ne dérange pas, vous auriez dû préciser d'entrée que les données étaient fictives, elles paraissaient réalistes et nous ne sommes pas des devins.

Je vous souhaite une excellente soirée
Bernard_XLD

XL 2019 modifications macro svp

simo161616

XLDnaute Junior

sylvanu

XLDnaute Barbatruc

simo161616

XLDnaute Junior

Pièces jointes

Bernard_XLD

XLDnaute Barbatruc

Discussions similaires