Copier lignes d'1 autre classeur si condition a et condition b Résolu

Question

Bonjour, 

N'ayant jamais programmer en VBA sans réel but autre que de m'amuser à colorier une case ou a copier une cellule, j'ai un peu du mal à mettre en code ce que je souhaite faire.
Je me permets donc de faire appel à vous et vais, pour ce faire, essayer d'être le plus clair possible quant à ma demande :

1. J'ai un premier fichier Excel qui me sert de BD.
2. J'ai un second fichier Excel dans lequel j'aimerai afficher les données selon deux conditions. 


Plus précisément :
- Si lors de la lecture de la case dans la BD, Di = "NA" alors on passe à la lecture de la ligne suivante.
- Si lors de la lecture de la case dans la BD, Di <> "NA" alors on regarde, toujours dans la BD, si Fi ou Gi ou Hi sont coloriées en rouge. Si VRAI alors, on copie la plage "Ai : Hi" de la BD et on la colle dans la dernière plage vide du second fichier et ensuite on passe à la lecture de la ligne suivante de la BD.

Pour éviter des soucis d'addressage, le fichier de BD initial étant sur un serveur, j'essaye d'abord de tester la chose entre 2 feuilles d'un même fichier.

Voilà le bout de code (je n'ai essayé de coder que la dernière partie de ma requête) que j'ai actuellement en ayant glané quelques infos par-ci, par-là...

Sub Bouton4_Cliquer()
    
    Dim nb_lignes As Integer
    
    Sheets("feuil1").Activate
    nb_lignes = WorksheetFunction.CountA(Range("A:A")) 'Equivalent de la fonction NBVAL dans Excel. Permet de prendre en compte automatiquement le nombre de ligne utilisées.
    
    For i = 4 To nb_lignes 'nb_lignes
        If Sheets("feuil1").Range("F" & i).Interior.Color = 255 Or Sheets("feuil1").Range("G" & i).Interior.Color = 255 Or Sheets("feuil1").Range("H" & i).Interior.Color = 255 Then 'Vérifie si une des cases est rouge
            Range("A" & i & ":H" & i).Copy 'copie la plage
            Sheets("feuil2").Activate 'active la feuille dans laquelle Excel va aller coller les données
            'Range("A" & i & ":H" & i).End(xlUp).Offset(1).Select 'recherche la première plage vide de la feuille feuil2
            ActiveSheet.Paste 'colle les données
            Application.CutCopyMode = False '"sort" du coller
        End If
   
 Next

End Sub


Configuration: Windows 7 / Mozilla 11.0

michel_m · Answer

Bonjour
je n'ai pas vu la condition en colonne D <>"NA"...

La couleur est- elle saisie manuellement ou par mise en forme conditionnelle ? 

recopie t' on le format rouge dans le fichier "cible" ?
 
 Michel

michel_m · Answer

Bonjour

ouf! tout ces imbrications avec des IF, des AND et des OR pas de la tarte pour commencer la semaine ! ==> un peu moins de cheveux !

nota: j'ai considéré qu'il y a vait du texte dans la cellule A3 feuil2
dans cette feuille2 a toi de faire les MEFC comme les bordures, couleurs etc

Option Explicit
'------------------------------------------------------
Sub recopier_si()
Dim Derlig As Integer, T_ok, Cptr As Integer, Col As Byte, T_out, Idx As Integer
Dim Ligvid As Integer

    Application.ScreenUpdating = False 'fige l'écran: confort et rapidité

    With Sheets(1)
'--------mémorisation tableaux
        Derlig = Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
        T_ok = .Range("A4:H" & Derlig)
        ReDim T_out(1 To UBound(T_ok), 1 To 8)
'-------récolte valeurs si conditions remplies
        For Cptr = 1 To UBound(T_ok)
            'd'après mise en forme conditionnelle
            'si 'D<>"NA" et A <>0 et _
                G=5 ou _
                    F="" ou _
                         H="" et A<>"NA" et C<>1 et E<>0  et E<>"PF" et E <>"I"
           If T_ok(Cptr, 4) <> "NA" Then
                 If T_ok(Cptr, 1) <> 0 Then
                    If T_ok(Cptr, 7) = 5 Or T_ok(Cptr, 6) = "" Or _
                         T_ok(Cptr, 8) = "" And T_ok(Cptr, 1) <> "NA" And T_ok(Cptr, 3) <> 1 And _
                                T_ok(Cptr, 5) <> 0 And T_ok(Cptr, 5) <> "PF" And T_ok(Cptr, 5) <> "I" Then
                                    'mémorisation valeurs A à  H
                                    Idx = Idx + 1
                                    For Col = 1 To 8
                                        T_out(Idx, Col) = T_ok(Cptr, Col)
                                Next Col
                        
                    End If
                End If
            End If
        Next Cptr
    End With

'---------restitution
    With Sheets(2)
        Ligvid = .Columns("A").Find("", .Range("A3")).Row
        .Cells(Ligvid, "A").Resize(UBound(T_out), 8) = T_out
        .Activate
    End With

End Sub

Copier lignes d'1 autre classeur si condition a et condition b

2 réponses

Votre réponse

Discussions similaires