Aide sur un code copier des lignes dans plusieurs onglet sur une condition

Le 08/12/2022 à 11:15

Bonjour à tous,

J'espère que vous allez bien,

svp j'ai besoin de votre aide, j'ai essayé d'adapter un code pour mon besoin par rapport à mon fichier de travail

mais lorsque j'exècute il me donne une erreur sur cette ligne

tabCoresp = Sheets("OUTIL").Range("F2:G10") où j'ai nommé la feuille du tableau de correspondance et j'ai sélectionné le tableau de correspondance.

si vous avez une idée pour m'aider

J'ai mis en PJ un exemple du fichier de travail.

Sub FiltrerDOSS()

Dim derLig, derCol As Integer   ' DERniere LIGne et DERniere COLonne
Dim actLig, cptLig As Integer   ' LIGne ACTuelle et ComPTeur de LIGnes
Dim actCol As Integer           ' COLonne ACTuelle
Dim tabSource()                 ' TABleau Source (DOSS)
Dim tabFiltre()                 ' TABleau pour conserver les numeror des adherents repondant au FILTRagE
Dim tabResult()                 ' TABleau RESULTat de l'application du filtre
Dim tabCoresp()                 ' TABleau de CORRESPondance entre les Pôles et les Onglets
Dim trvOng As Integer           ' pour savoir si l'ONGlet est TRouVé

    tabCoresp = Sheets("OUTIL").Range("F2:G10")     ' Initialiser le TABleau de CORrESPondance - voir dans l'onglet OUTIL
    trvOng = 0                          ' Pour l'instant nous n'avons pas trouvé la correspondance
    actLig = 1                          ' A partir de la 1ere ligne

    ' Tant Que (LIGne ACTuelle < nombre de ligne du TABleau de CORrESPondance) ET Que (ONGlet TRouVé = 0)
    While actLig < UBound(tabCoresp, 1) + 1 And trvOng = 0
        If ActiveSheet.Name = tabCoresp(actLig, 2) Then     ' Si l'onglet actuel = LIGne ACTuelle du TABleau de CORrESPondance
            trvOng = actLig                                 '   TRouVé ONGlet = LIGne ACTuelle
        Else                                                ' Sinon
            actLig = actLig + 1                             '   Passer à la LIGne ACTuelle +1 - donc la suivante
        End If                                              ' Fin du Si
    Wend                                                    ' Fin du Tant Que

    If trvOng > 0 Then                                          ' Si nous avons TRouVé l'ONGlet - puisqu'il > 0
        Application.ScreenUpdating = False                      ' Pour aller plus vite => pas de rafraichissement ecran
        Application.EnableEvents = False
        Worksheets("DOSS").Activate                        ' Activer l'onglet Adhérents
        Cells(1, 1).Select                                      ' Se placer au Debut de la liste pour...
        derLig = Selection.End(xlDown).Row                      ' Rechercher la DERniere LIGne de la liste
        Cells(1, 1).Select                                      ' Se replacer au Debut de la liste pour...
        derCol = Selection.End(xlToRight).Column                ' Rechercher la DERniere COLonne de la liste
        tabSource = Range(Cells(2, 1), Cells(derLig, derCol))   ' Copier la liste dans le TABleau SOURCE
        cptLig = 0                                              ' Pour l'instant le ComPTeur de LIGne est à 0

        ' Parcourir le TABleau SOURCE
        For actLig = 1 To UBound(tabSource, 1)
            ' Si le pôle est egal à l'onglet en cours
            ' dans le TABleau SOURCE la colonne 1 est la colonne Pole
            If UCase(tabSource(actLig, 1)) = UCase(tabCoresp(trvOng, 1)) Then
                cptLig = cptLig + 1                             ' Ajouter 1 au ComPTeur de lIGne
                ReDim Preserve tabFiltre(1 To cptLig)           ' REDIMensionner le TABleau de FILTRagE
                tabFiltre(cptLig) = actLig                      ' Affecter la LIGne ACTuelle au TABleau de FILTRagE
            End If                                              ' Fin du Si
        Next                                                    ' Fin du Parcours du TABleau SOURCE

        ' Si nous avons trouve au moins une ligne
        If cptLig > 0 Then
            ' REDIMensionner le TABleau de RESULTat au nombre de ligne du TABleau de FILTRagE
            ReDim tabResult(1 To UBound(tabFiltre, 1), 1 To UBound(tabSource, 2))
            ' Parcourir le TABleau de FILTRagE pour remplir le TABleau REULTat
            For actLig = 1 To UBound(tabFiltre, 1)
                ' Parcourir toutes les colonnes du TABleau SOURCE
                For actCol = 1 To UBound(tabSource, 2)
                    ' La position actuelle dans le TABleau RESULTat devient
                    ' la position filtrée du TABleau SOURCE
                    tabResult(actLig, actCol) = tabSource(tabFiltre(actLig), actCol)
                Next    ' Fin du Parcours de toutes les colonnes du TABleau SOURCE
            Next        ' Fin du Parcours du TABleau de FILTRagE

            'Afficher l'onglet du filtre
            Application.EnableEvents = False
            Worksheets(tabCoresp(trvOng, 2)).Activate

            ' Effacer les anicennes donnees
            Cells(2, 1).Select                                      ' Se placer au Debut de la liste pour...
            derLig = Selection.End(xlDown).Row                      ' Rechercher la DERniere LIGne de la liste
            Cells(2, 1).Select                                      ' Se replacer au Debut de la liste pour...
            derCol = Selection.End(xlToRight).Column                ' Rechercher la DERniere COLonne de la liste
            Range(Cells(2, 1), Cells(derLig, derCol)).ClearContents

            ' Recopier le TABleau RESULTat dans la premiere cellule en redimensionnant aux bonnes dimensions
            Cells(2, 1).Resize(UBound(tabResult, 1), UBound(tabResult, 2)) = tabResult

            Application.ScreenUpdating = True                       ' Rafraichire l'ecran maintenant

        Else
            ' Nous n'avons PAS trouve au moins une ligne !
            MsgBox "Il n'y a pas de Pôle " + tabCoresp(trvOng, 1) + " dans le fichier des DOSS", vbInformation + vbOKOnly, "Désolé !"
            Application.EnableEvents = False
            Worksheets(tabCoresp(trvOng, 2)).Activate
            Cells(2, 1).Select
        End If  ' Fin du Si nous avons trouve au moins une ligne

    Else
        ' Nous n'avons PAS trouve l'onglet dans le TABleau de CORrESPondance !
        MsgBox "Placez-vous sur un onglet de Pôle avant de commencer le traitement", vbInformation + vbOKOnly, "Information"
    End If  ' Fin du Si nous avons TRouVé l'ONGlet
    Application.EnableEvents = True
End Sub
11fichier-travail.xlsx (26.11 Ko)
Le 08/12/2022 à 12:28

Bonjour,

Il faut déclarer la variable ainsi :

Dim tabCoresp

Au départ, c'est un variant qui sera forcé en tableau par son affectation.

Edit : Voici sinon une adaptation de votre code :

Sub FiltrerDOSS()
dim tSrc, tFlt, sWsName$, sPole$, i&, k&, n&, dl&, dc&
Application.EnableEvents = False
with activesheet
    sWsName$ = .Name
    with Sheets("OUTIL")
        sPole = application.index(.Range("F2:F10"), application.match(sWsName, .Range("G2:G10"), 0))
    end with
    If not iserror(sPole) Then                     
        tSrc = Worksheets("DOSS").range("SOURCE").value          
        For i = lbound(tSrc) To UBound(tSrc)
            If UCase(tSrc(i, 1)) = UCase(sPole) Then
                n = n + 1: ReDim Preserve tFlt(lbound(tSrc, 2) to ubound(tSrc, 2), 1 To n)           
                for k = lbound(tSrc, 2) to ubound(tSrc, 2)
                    tFlt(k, n) = tSrc(i, k)
                next k                   
            End If                                              
        Next i
    end if
    dl = .cells(.rows.count, 1).end(xlup).row
    dc = .cells(2, .columns.count).end(xltoleft).column
    .Range(.Cells(2, 1), .Cells(dl, dc)).ClearContents
    if n > 0 then
        .Cells(2, 1).Resize(n, UBound(tFlt)) = application.transpose(tFlt)
    else
        msgbox "aucune correspondance pour " & sWsName
    end if
end with
Application.EnableEvents = True
End Sub

Attention, il faut un tableau structuré nommé SOURCE sur la feuille DOSS.

D'ailleurs, il faudrait mettre la table de correspondance de la feuille OUTIL en TS et il faudrait que la feuille active (un pôle si j'ai compris) contienne un TS également. Ce serait beaucoup plus clair et simple à coder.

Cdlt,

Le 08/12/2022 à 15:00

Bonjour

merci pour votre retour

je pense que c'est déclaré

Dim tabCoresp()                 ' TABleau de CORRESPondance entre les Pôles et les Onglets

ou bien comment faut il le déclarer?

J'ai essayé de prendre l'adaptation du code, dans mon fichier

le tableau source est structuré dans la feuille "DOSS" mais j'ai pas compris comment le nommer

merci d'avance.

cordialement

Le 08/12/2022 à 15:08

Re,

Il aurait fallu déclarer la variable sans les parenthèses

dim tabCoresp

ou en précisant son type (qui est le type par défaut) :

dim tabCoresp as variant

Pour renommer le tableau structuré de la feuille DOSS, il faut cliquer sur une de ses cellules. Alors un onglet contextuel, nommé "Création" apparait en haut à droite (il est coloré). Il faut se rendre dessus et dans la barre des noms qui se trouve en haut à gauche, il faut entrer le nom "SOURCE" et valider avec la touche entrée.

Rechercher des sujets similaires à "aide code copier lignes onglet condition"