Code pour passer au suivant

Bonjour tout le monde,

J'ai créer un fichier excel avec une macro qui récupère les données de l'onglet "identification" de plusieurs fichier excel depuis un répertoire.

Il ouvre l'onglet "identification" de chaque fichier, lance la fonction cell.find dans les 5 étapes (avec différent mots dans chaque étapes) et il copie les valeurs pour me les coller sur mon fichier excel.

Maintenant le problème c'est que parfois dans ces onglets il n'y a pas le mot rechercher, et lorsqu'il ne trouve pas le cell.find (dans n'importe quel étape) la macro plante.

Moi je souhaite que lorsque le cell.find ne fonctionne pas je veut passer à l'étape suivante.

Voici le code :

Sub Macro2()

Const str_nameshedit As String = "Informatique" 'Onglet où sont situé les informations à extraire

Dim wkb_source As Workbook
Dim wsh_result As Worksheet
Dim Chemin As String, Fichier As String
Dim i As Long

Set wsh_result = ActiveSheet
Chemin = [B1]
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Fichier = Dir(Chemin & "*.xls*") 'Chemin d'accès

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Choisir Values ou All pour le Paste:=xlPastexxx
i = 5 'Début = ligne 5
Do While Len(Fichier) > 0

    '1ère étape nb pc
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Sheets("Informatique").Select
    Cells.Find(What:="Nombre de PC :", After:=ActiveCell, _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
    Cells(i, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    '2ème étapes nb d'écran
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Sheets("Informatique").Select
    Cells.Find(What:="nombre d'écran", After:=ActiveCell, _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, "N34").Select
    Selection.Copy
    Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
    Cells(i, 2).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    '3ème étapes nb de téléphone
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Sheets("Informatique").Select
    Cells.Find(What:="nombre de téléphone", After:=ActiveCell, _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
    Cells(i, 13).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

        '4ème étapes nbr de fil
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Sheets("Informatique").Select
    Cells.Find(What:="nombre de fil", After:=ActiveCell, _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
    Cells(i, 21).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

        '5ème étapes sécurité
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Sheets("Informatique").Select
    Cells.Find(What:="sécurité", After:=ActiveCell, _
        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
    Cells(i, 34).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

i = i + 16 'Suivant
    wkb_source.Close
    Fichier = Dir()
Loop

Set wkb_source = Nothing
Set wsh_result = Nothing

MsgBox "Terminé"

End Sub

Bonjour Yassdu, bonjour le forum,

Après une recherche, Select ou tout autre fonction sur la recherche plantera si aucune occurrence n'est trouvée. Une solution simple consiste à utiliser un variable de type Range qui déclare la variable puis de la définir avec la fonction Find. Ensuite un simple condition : If Not Recherche Is Nothing Then... Comme tu as 5 étapes ça te fera 5 variables ou une seule variable pour chaque étape comme dans l'exemple ci-dessous en la réinitialisant à la fin :

Const str_nameshedit As String = "Informatique" 'Onglet où sont situé les informations à extraire
Dim wkb_source As Workbook
Dim wsh_result As Worksheet
Dim Chemin As String, Fichier As String
Dim i As Long
Dim R As Range '<---------- ICI

Set wsh_result = ActiveSheet
Chemin = [B1]
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Fichier = Dir(Chemin & "*.xls*") 'Chemin d'accès
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Choisir Values ou All pour le Paste:=xlPastexxx
i = 5 'Début = ligne 5
Do While Len(Fichier) > 0
    '1ère étape nb pc
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Set R = Sheets("Informatique").Cells.Find(What:="Nombre de PC :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate '<---------- ICI
    If Not R Is Nothing Then '<---------- ICI
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
        Cells(i, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If '<---------- ICI
    Set R = Nothing '<---------- ICI

Évite les Select inutile qui ne font que ralentir l'exécution du code et sont source de nombreux plantages...

Merci pour ta réponse et de m'accorder un peu de temps !

J'ai copier ton code mais il m'affiche un blocage au niveau du set R sheets ("informatique"), tu as une idée ?

Le message : Impossible de lire la propriété activate de la classe range

Re,

Oui désolé j'ai oublié de supprimer .Activate à la fin :

Const str_nameshedit As String = "Informatique" 'Onglet où sont situé les informations à extraire
Dim wkb_source As Workbook
Dim wsh_result As Worksheet
Dim Chemin As String, Fichier As String
Dim i As Long
Dim R As Range '<---------- ICI

Set wsh_result = ActiveSheet
Chemin = [B1]
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Fichier = Dir(Chemin & "*.xls*") 'Chemin d'accès
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Choisir Values ou All pour le Paste:=xlPastexxx
i = 5 'Début = ligne 5
Do While Len(Fichier) > 0
    '1ère étape nb pc
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Set R = Sheets("Informatique").Cells.Find(What:="Nombre de PC :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) '<---------- ICI
    If Not R Is Nothing Then '<---------- ICI
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
        Cells(i, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If '<---------- ICI
    Set R = Nothing '<---------- ICI

Merci infiniment sa marche parfaitement !!!!!

Cela dit je viens de constater qu'il me le faut aussi pour l'onglet … je voulais avoir le code si l'onglet "identification" n'existe pas dans le fichier. C'est le même principe, si il n'y pas l'onglet, on passe au fichier suivant !

Je crois que j'ai pu bidouiller un peu le code

Sub Macro2()
Const str_nameshedit As String = "Informatique" 'Onglet où sont situé les informations à extraire
Dim wkb_source As Workbook
Dim wsh_result As Worksheet
Dim Chemin As String, Fichier As String
Dim i As Long
Dim R As Range '<---------- ICI

Set wsh_result = ActiveSheet
Chemin = [B1]
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Fichier = Dir(Chemin & "*.xls*") 'Chemin d'accès
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Choisir Values ou All pour le Paste:=xlPastexxx
i = 5 'Début = ligne 5
Do While Len(Fichier) > 0
    '1ère étape nb pc
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    If Not wsh_result Is Nothing Then '<------ à vérifié
    Set R = Sheets("Informatique").Cells.Find(What:="Nombre de PC :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) '<---------- ICI
    End If <------ à vérifié
    Set wsh_result = Nothing <------ à vérifié
    If Not R Is Nothing Then '<---------- ICI
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
        Cells(i, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If '<---------- ICI
    Set R = Nothing '<---------- ICI

i = i + 16 'Suivant
    wkb_source.Close
    Fichier = Dir()
Loop

Set wkb_source = Nothing
Set wsh_result = Nothing

MsgBox "Terminé"

End Sub

Non sa ne marche pas ...

HELP

Sa a l'air de bien fonctionner, j'ai trouver la solution sur un autre forum et c'est toi qui avait trouver la solution, tu est partout toi

Sub Macro2()
Const str_nameshedit As String = "Informatique" 'Onglet où sont situé les informations à extraire
Dim wkb_source As Workbook
Dim wsh_result As Worksheet
Dim Chemin As String, Fichier As String
Dim i As Long
Dim R As Range '<---------- ICI

Set wsh_result = ActiveSheet
Chemin = [B1]
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Fichier = Dir(Chemin & "*.xls*") 'Chemin d'accès
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Choisir Values ou All pour le Paste:=xlPastexxx
i = 5 'Début = ligne 5
Do While Len(Fichier) > 0
    '1ère étape nb pc
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    On Error Resume Next <--- !!!
    Set R = Sheets("Informatique").Cells.Find(What:="Nombre de PC :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) '<---------- ICI
    If Err <> 0 Then <--- !!!
    wkb_source.Close <--- !!!
    End If <--- !!!

    If Not R Is Nothing Then '<---------- ICI
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique (copie la valeur) - Copie.xlsm").Activate
        Cells(i, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If '<---------- ICI
    Set R = Nothing '<---------- ICI

i = i + 16 'Suivant
    wkb_source.Close
    Fichier = Dir()
Loop

Set wkb_source = Nothing
Set wsh_result = Nothing

MsgBox "Terminé"

End Sub

Bonjour Yassdu, bonjour le forum,

Difficile de s'y retrouver entre les "ça marche" et les "ça marche pas"... Pourrais-tu reposer ta question clairement. Avec un fichier exemple ça serait encore mieux...

Bonjour,

Tu as résolu cette problématique : si dans l'onglet "informatique" il ne trouve pas le mot rechercher ( cell.find(...) ), alors on passe à l'étape suivante.

Cela dit j'ai des fichiers qui n'ont pas l'onglet "informatique", donc quand je lance la macro, il plante ici :

Set R = Sheets("Informatique").Cells.Find...........
ce qui est logique car il ne trouve pas l'onglet en question ...

Je te laisse le code avec que 2 étapes sur 5 pour ne pas encombrer trop le forum.

Sub Macro2()

Const str_nameshedit As String = "Informatique" 'Onglet où sont situé les informations à extraire
Dim wkb_source As Workbook
Dim wsh_result As Worksheet
Dim Chemin As String, Fichier As String
Dim i As Long
Dim R As Range '<---------- ICI

Set wsh_result = ActiveSheet
Chemin = [B1]
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
Fichier = Dir(Chemin & "*.xls*") 'Chemin d'accès
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Choisir Values ou All pour le Paste:=xlPastexxx
i = 5 'Début = ligne 5
Do While Len(Fichier) > 0

    '1ère étape nb pc
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Set R = Sheets("Informatique").Cells.Find(What:="Nombre de PC contenus dans l'arbo :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) '<---------- ICI
    If Not R Is Nothing Then '<---------- ICI
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique totem.xlsm").Activate
        Cells(i, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If '<---------- ICI
    Set R = Nothing '<---------- ICI

    '2ème étape nb d'écran
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Set R = Sheets("Informatique").Cells.Find(What:="Nombre d'écran :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) '<---------- ICI
    If Not R Is Nothing Then '<---------- ICI
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique totem.xlsm").Activate
        Cells(i, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If '<---------- ICI
    Set R = Nothing '<---------- ICI

i = i + 10  'Suivant
    wkb_source.Close
    Fichier = Dir()
Loop

Set wkb_source = Nothing
Set wsh_result = Nothing

MsgBox "Terminé"

End Sub

Merci

Re,

Ok, essaie comme ça :

Sub Macro2()

Const str_nameshedit As String = "Informatique" 'Onglet où sont situé les informations à extraire
Dim wkb_source As Workbook
Dim wsh_result As Worksheet
Dim Chemin As String, Fichier As String
Dim i As Long
Dim R As Range
Dim OS As Worksheet '<---------- ICI

Set wsh_result = ActiveSheet
Chemin = [B1]
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

Fichier = Dir(Chemin & "*.xls*") 'Chemin d'accès
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Choisir Values ou All pour le Paste:=xlPastexxx
i = 5 'Début = ligne 5
Do While Len(Fichier) > 0

    '1ère étape nb pc
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False

    '***
    'ici
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OS = Worksheets("Informatique") 'définit l'onglet source OS (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        GoTo suite 'va à l'étiquette "suite
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    '***

    Set R = Sheets("Informatique").Cells.Find(What:="Nombre de PC contenus dans l'arbo :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not R Is Nothing Then
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique totem.xlsm").Activate
        Cells(i, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If
    Set R = Nothing

    '2ème étape nb d'écran
    Set wkb_source = Workbooks.Open(Chemin & Fichier)
    Application.DisplayAlerts = False
    Set R = Sheets("Informatique").Cells.Find(What:="Nombre d'écran :", After:=ActiveCell, _
       LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
       SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) '<---------- ICI
    If Not R Is Nothing Then '<---------- ICI
        Range(R, R.End(xlToRight)).Copy
        Windows("Informatique totem.xlsm").Activate
        Cells(i, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=True
    End If
    Set R = Nothing

i = i + 10  'Suivant
    wkb_source.Close
    Fichier = Dir()
suite: '<---------- ICI
Loop

Set wkb_source = Nothing
Set wsh_result = Nothing

MsgBox "Terminé"

End Sub

Re,

La macro se lance sans se terminer, je suis obliger de forcer l'arrêt avec la touche échap.

Mais ton code à l'air de fonctionner, peut-tu remédier à cela

Ok c'était ton étiquette que tu a placé juste avant le loop, normal que ma tête elle tourne

Sujet encore une fois résolu MERCI !

Re,


Oui pardon, l'etiquette suite est à mettre avant la ligne Fichier = Dir().

Rechercher des sujets similaires à "code passer suivant"