Erreur macro de tri et coller

Résolu/Fermé
bassmart Messages postés 281 Date d'inscription jeudi 19 février 2015 Statut Membre Dernière intervention 19 décembre 2023 - 22 avril 2015 à 18:51
bassmart Messages postés 281 Date d'inscription jeudi 19 février 2015 Statut Membre Dernière intervention 19 décembre 2023 - 7 mai 2015 à 18:46
Bonjour à tous!

J'ai un fichier contenant 1 feuille de compilation et 4 autres feuilles contenant les données triés selon leur type. Ma macro fonctionnais très bien quand il y avais déjà des données dans les autres feuilles et là je fais des test avec une fichier complètement vide.

J'ai un problème avec une macro qui tri et copie les données selon leur type dans chacune des pages correspondantes. J'ai une erreur 1001 sur la ligne
With ws.Range(tabtri & nl)
                .Sort key1:=.Cells(1, Col), order1:=xlAscending, Header:=xlNo

et je ne comprend pourquoi! Quand je vais dans la première feuille de destination (Forage), l'entête en devenue sur plusieurs ligne (20 lignes) et aucune valeur n'a été copié. La première ligne vide après l'entête est la 8 pour cette feuille.

Voici le code complet:
Sub CopieFeuillets()
' Macro de Copie & de Tri

Dim f As Worksheet

Application.ScreenUpdating = False

For Each f In ActiveWorkbook.Worksheets
    f.Unprotect
Next

   With Sheets("Coordonnées")
  
        For i = 1 To 4
            On Error Resume Next
            Erase critères
            On Error GoTo 0
            Select Case i
            
            Case 1
                wsn = "FORAGE"
                critères = Array("F", "FC", "FS", "FSZ")
                Col = "A" ' colonne dans laquelle mettre le n° de sondage, est également la colonne pour le tri
               PL = 8 'première ligne des données dans wsn
               tabtri = "A" & PL & ":N" ' tableau à trier
           Case 2
                wsn = "CPTU"
                critères = Array("C", "CR", "FC", "M")
                Col = "A"
                PL = 7
                tabtri = "A" & PL & ":O"
            Case 3
                wsn = "Piézomètres"
                critères = Array("Z", "FSZ")
                Col = "B"
                PL = 8
                tabtri = "A" & PL & ":M"
            Case 4
                wsn = "Inclinomètres"
                critères = Array("I")
                Col = "B"
                PL = 7
                tabtri = "A" & PL & ":H"
            End Select
           
            .Range("$A$4:$N$64").AutoFilter Field:=4, Criteria1:=critères, Operator:=xlFilterValues         'on filtre les données de coordonnées
           
           Set ws = Sheets(wsn)    ' ws = référence de la feuille
           nl = ws.Cells(Rows.Count, Col).End(xlUp).Row    ' nl pointeur de dernière ligne utilisée dans la feuille basé sur colonne col
           If nl < PL Then nl = PL - 1
            For Each r In .Range(.Range("C5"), .Range("C5").End(xlDown)).SpecialCells(xlVisible)    ' on parcourt toutes les cellules sélectionnées de la colonne  C, (r=cellule en cours)
               Set re = ws.Range(Col & ":" & Col).Find(r.Value, lookat:=xlWhole)    'on recherche le n°de sondage dans la colonne col
               If re Is Nothing Then    'si non trouvé
                    'ajoute une nouvelle ligne avant derniere ligne
                    ws.Rows(nl).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    'derniere ligne + 1
                    ws.Cells(nl, Col) = ws.Cells(nl + 1, Col)
                    ws.Cells(nl + 1, Col) = r.Value  ' on met le numéro de sondage en colonne col
               End If
            Next
            With ws.Range(tabtri & nl)
                .Sort key1:=.Cells(1, Col), order1:=xlAscending, Header:=xlNo
            End With
        Next i
        If Worksheets("Coordonnées").AutoFilterMode Then
            Worksheets("Coordonnées").AutoFilterMode = False
        End If
    End With
    

For Each f In ActiveWorkbook.Worksheets
    f.Protect
Next
    
Application.EnableEvents = True

End Sub


Pouvez-vous m'aider?

Merci!
A voir également:

1 réponse

bassmart Messages postés 281 Date d'inscription jeudi 19 février 2015 Statut Membre Dernière intervention 19 décembre 2023 1
22 avril 2015 à 20:16
Petite précision!

Quand je roule la macro pas à pas, je voie qu'il m'ajoute une ligne dans mon entête qui termine normalement à la ligne 7, mais là qui termine à la ligne 8. Et le problème semble venir de la ligne suivante
 Set re = ws.Range(Col & ":" & Col).Find(r.Value, lookat:=xlWhole)    'on recherche le n°de sondage dans la colonne col
               If re Is Nothing Then    'si non trouvé
                    'ajoute une nouvelle ligne avant derniere ligne
                    ws.Rows(nl).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    'derniere ligne + 1


Et quand je passe un espion sur la valeur de "re'", la réponse est "Nothing". Mon tableau contient une vingtaine de ligne, mais qui sont vide.

Est-ce que le problème peut venir de là?

Merci!
0
bassmart Messages postés 281 Date d'inscription jeudi 19 février 2015 Statut Membre Dernière intervention 19 décembre 2023 1
23 avril 2015 à 14:46
Bon, j'ai trouvé la source de mon problème!

Pour le "re" égal "nothing", c'est normal parce que ma macro cherche si la valeur à copier se retrouve dans le tableau de destination,donc tout est ok pour ça!

Mon problème provient de la valeur du "nl"! Quand je n'ai rien la valeur est égal à 7 alors que ma première ligne disponible est la ligne 8 qui correspond à mon PL de cette feuille.

Mon problème se situe dans les lignes suivantes de code:
If nl < PL Then nl = PL - 1
            For Each r In .Range(.Range("C5"), .Range("C5").End(xlDown)).SpecialCells(xlVisible)    ' on parcourt toutes les cellules sélectionnées de la colonne  C, (r=cellule en cours)
               Set re = ws.Range(Col & ":" & Col).Find(r.Value, lookat:=xlWhole)    'on recherche le n°de sondage dans la colonne col
               If re Is Nothing Then    'si non trouvé
                    'ajoute une nouvelle ligne avant derniere ligne
                    ws.Rows(nl).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    'derniere ligne + 1
                    ws.Cells(nl, Col) = ws.Cells(nl + 1, Col)
                    ws.Cells(nl + 1, Col) = r.Value  ' on met le numéro de sondage en colonne col
               End If
            Next

Elle copie la première valeur sur la première ligne (ligne 8) correctement mais par la suite, il m'ajoute des lignes au dessus de cette valeur donc ligne 7.

Comment régler ce problème?

Merci!
0
bassmart Messages postés 281 Date d'inscription jeudi 19 février 2015 Statut Membre Dernière intervention 19 décembre 2023 1
Modifié par bassmart le 1/05/2015 à 18:29
Bonjour à tous!

Voici le fichier en question: https://www.cjoint.com/?0EbrH11lSey

Lorsque je modifie la ligne
If nl < PL Then nl = PL - 1
pour
If nl < PL Then nl = PL + 1
. Il m'ajoute une ligne à la bonne place, mais quand il copie les valeurs dans la feuille, il laisse toujours une ligne vide entre la première valeur et l'entête et il ne recopie pas le format (bordures de ligne). Probablement à cause que ma valeur nl revient plus bas dans ces 2 lignes
 ws.Cells(nl, Col) = ws.Cells(nl + 1, Col)
                    ws.Cells(nl + 1, Col) = r.Value 


J'espère que quelqu'un peux m'aidé?
0
bassmart Messages postés 281 Date d'inscription jeudi 19 février 2015 Statut Membre Dernière intervention 19 décembre 2023 1 > bassmart Messages postés 281 Date d'inscription jeudi 19 février 2015 Statut Membre Dernière intervention 19 décembre 2023
7 mai 2015 à 18:46
Problème résolu!

J'ai garder la ligne tel que modifié au par avant
If nl < PL Then nl = PL + 1

et J'ai changé les 2 lignes contenant la valeur de "nl":
ws.Cells(nl, Col) = ws.Cells(nl - 1, Col)
                    ws.Cells(nl - 1, Col) = r.Value  ' on met le numéro de sondage en colonne col
0