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().