Cade VBA d'extraction avec 1 condition

thomasdu40 · 18 Août 2010

Bonjour,

Je m'adresse aux professionnels d'Excel pour ce petit souci.

J'ai le code suivant qui m'extrait d'un fichier les données présentes dans l'onglet "ConstatsISO" pour alimenter un deuxième fichier dans des cellules respectives. Jusque là tout fonctionne correctement.🙂

Sauf que dans le fichier où sont extraites les données présentes dans les cellules de la colonne B ce sont des valeurs égales soit à E, PA, Obs, PF, PP ou PS qui s'y trouvent et saisies par des opérateurs. Ces valeurs se greffent dans la colonne P du second fichier.

Code:

Range("P" & lig).Value = .Range("B" & k).Value

Je voudrai que la macro m'extrait ces valeurs SAUF les cellules contenant la valeur PF. Si la valeur de la cellule est égale à PF il ne fait pas d'extraction et passe à la ligne suivante. Je pense qu'il faut y mettre une condition mais comment ?😕

Merci. Ci-dessous code complet.

Code:

With Wb.Sheets("ConstatsISO")
        For k = 8 To .[A65536].End(3).Row
            If .Range("A" & k) <> "" Then
                lig = [I65536].End(3).Row + 1
                Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
                Range("I" & lig).Value = .Range("A" & k).Value
                Range("P" & lig).Value = .Range("B" & k).Value
                Range("H" & lig).Value = .Range("C" & k).Value
                Range("Q" & lig).Value = .Range("D" & k).Value
                Range("R" & lig).Value = .Range("E" & k).Value
            End If
        Next
    End With

Odesta · 19 Août 2010

Re : Cade VBA d'extraction avec 1 condition

Bonjour à tous
Si j'ai bien compris, le but c'est de ne rien fire si le contenu est égale à PF ?

Je voudrai que la macro m'extrait ces valeurs SAUF les cellules contenant la valeur PF. Si la valeur de la cellule est égale à PF il ne fait pas d'extraction et passe à la ligne suivante. Je pense qu'il faut y mettre une condition mais comment ?

pourriez-vous me rexpliquer ceci svp ?

Olivier

ChTi160 · 19 Août 2010

Re : Cade VBA d'extraction avec 1 condition

Salut Thomasdu40
Bonjour le Fil
Bonjour le Forum
on peut peut être mettre ceci (une seule condition)

With Wb.Sheets("ConstatsISO22000")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" and .Range("B" & k).Value <> "PF" Then
lig = [I65536].End(3).Row + 1

Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
Range("I" & lig).Value = .Range("A" & k).Value
Range("P" & lig).Value = .Range("B" & k).Value
Range("H" & lig).Value = .Range("C" & k).Value
Range("Q" & lig).Value = .Range("D" & k).Value
Range("R" & lig).Value = .Range("E" & k).Value

End If
Next
End With

Bonne journée

thomasdu40 · 19 Août 2010

Re : Cade VBA d'extraction avec 1 condition

Merci Youky ainsi qu'à tous ceux qui m'ont aidés.

Sujet clôturé.

Le code fonctionne correctement. En résumé la macro se déroule parfaitement en fonction de mes attentes ci-joint le code complet :

Code:

Private Sub CommandButton1_Click()
Dim WbPrincipal As Workbook, Wb As Workbook
Dim nomFichier As String, fichierAOuvrir As String
Dim i As Long, cpt As Long, k As Long, lig As Long

Set WbPrincipal = ActiveWorkbook
  nomFichier = TextBox1.Text
    With Application.FileSearch
        .NewSearch
        .LookIn = "G:\S - ISO\A - Audits\"    'on regarde dans ce répertoire
      .SearchSubFolders = True    'on regarde dans les sous-dossiers également
      .Filename = nomFichier    'nom du fichier à chercher
      .MatchTextExactly = False    'on cherche dans les fichiers qui contiennent le nom du fichier cherché
      .FileType = msoFileTypeExcelWorkbooks    'on cherche que les classeur excel
      If .Execute() > 0 Then    'si un fichier est trouvé
          For i = 1 To .FoundFiles.Count    'on boucle sur tous les fichiers comportant le nom du fichier
              If .FoundFiles(i) Like "*" & nomFichier & ".xls" Then    'si le fichier correspond exactement au nom recherché
                  fichierAOuvrir = .FoundFiles(i)
                    cpt = cpt + 1    'on incrémente un compteur
              End If
            Next i
        End If
        If cpt > 0 Then
            MsgBox "Il y a " & cpt & " " & IIf(cpt = 1, "fichier intitulé ", "fichiers intitulés ") & """" & nomFichier & """.", vbInformation
        Else
            MsgBox "Fichier Absent", vbExclamation: Exit Sub
        End If
    End With
    Workbooks.Open (fichierAOuvrir)
    Set Wb = ActiveWorkbook
    Windows(WbPrincipal.Name).Activate
       With Wb.Sheets("ConstatsISO")
        For k = 8 To .[A65536].End(3).Row
            If .Range("A" & k) <> "" Then
                lig = [I65536].End(3).Row + 1
                If .Range("B" & k).Value <> "PF" Then
                Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
                Range("I" & lig).Value = .Range("A" & k).Value
                Range("P" & lig).Value = .Range("B" & k).Value
                Range("H" & lig).Value = .Range("C" & k).Value
                Range("Q" & lig).Value = .Range("D" & k).Value
                Range("R" & lig).Value = .Range("E" & k).Value
                End If
            End If
        Next
        End With



    With Wb.Sheets("ConstatsISO22000")
        For k = 8 To .[A65536].End(3).Row
            If .Range("A" & k) <> "" Then
                lig = [I65536].End(3).Row + 1
                If .Range("B" & k).Value <> "PF" Then
                Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
                Range("I" & lig).Value = .Range("A" & k).Value
                Range("P" & lig).Value = .Range("B" & k).Value
                Range("H" & lig).Value = .Range("C" & k).Value
                Range("Q" & lig).Value = .Range("D" & k).Value
                Range("R" & lig).Value = .Range("E" & k).Value
                End If
            End If
        Next
    End With

    With Wb.Sheets("ConstatsIFS")
        For k = 6 To .[C65536].End(3).Row
            If .Range("C" & k) <> "" Then
                lig = [I65536].End(3).Row + 1
                If .Range("D" & k).Value <> "PF" Then
                Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
                Range("I" & lig).Value = .Range("C" & k).Value
                Range("P" & lig).Value = .Range("D" & k).Value
                Range("H" & lig).Value = .Range("E" & k).Value
                Range("Q" & lig).Value = .Range("B" & k).Value
                Range("R" & lig).Value = .Range("F" & k).Value
                End If
            End If
        Next
    End With

    With Wb.Sheets("ConstatsBRC")
        For k = 6 To .[C65536].End(3).Row
            If .Range("C" & k) <> "" Then
                lig = [I65536].End(3).Row + 1
                If .Range("D" & k).Value <> "PF" Then
                Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
                Range("I" & lig).Value = .Range("C" & k).Value
                Range("P" & lig).Value = .Range("D" & k).Value
                Range("H" & lig).Value = .Range("E" & k).Value
                Range("Q" & lig).Value = .Range("B" & k).Value
                Range("R" & lig).Value = .Range("F" & k).Value
                End If
            End If
        Next
    End With

    With Wb.Sheets("ConstatsIFS_BRC")
        For k = 6 To .[C65536].End(3).Row
            If .Range("C" & k) <> "" Then
                lig = [I65536].End(3).Row + 1
                If .Range("D" & k).Value <> "PF" Then
                Range("N" & lig).Value = Wb.Sheets("Plan d'audit").[H8].Value
                Range("I" & lig).Value = .Range("C" & k).Value
                Range("P" & lig).Value = .Range("D" & k).Value
                Range("H" & lig).Value = .Range("E" & k).Value
                Range("Q" & lig).Value = .Range("B" & k).Value
                Range("R" & lig).Value = .Range("F" & k).Value
                End If
            End If
        Next
    End With
    Wb.Close False
End Sub

Cade VBA d'extraction avec 1 condition

thomasdu40

Guest

Odesta

XLDnaute Impliqué

ChTi160

XLDnaute Barbatruc

thomasdu40

Guest

Discussions similaires

Cade VBA d'extraction avec 1 condition

thomasdu40

Guest

Odesta

XLDnaute Impliqué

ChTi160

XLDnaute Barbatruc

thomasdu40

Guest

Discussions similaires

Privacy & Transparency

Privacy & Transparency