Macro réunissant fonctions recherche et extraction

[thomasdu40]

Bonjour,

Je voudrai qu'avec une macro je puisse rechercher un fichier sur un chemin d'accès bien précis. Si la macro trouve ce fichier, qu'elle l'ouvre et qu'elle extrait des données issues de plusieurs onglets. Est-ce possible ?

J'ai effectué pas mal de recherche et honnêtement je coince.

Pour explication, je joins une page regroupant le déroulement des opérations.

Merci.

 

[youky(BJ)]

Re : Macro réunissant fonctions recherche et extraction

Au cas Ou,
Ma façon de faire. . . .

Bruno

Private Sub CommandButton1_Click()
Dim Wb As Workbook
Feuil1.Select 'Feuil1(nom de gauche en projet)
chemin = "G:\S-ISO\A-Audits\"
fichier = TextBox1.Text & ".xls"
On Error Resume Next
Set Wb = GetObject(chemin & fichier)
If Err <> 0 Then MsgBox "Fichier Absent": Exit Sub
lig = [N65536].End(3).Row + 1
[COLOR="Red"]audit = Wb.Sheets("Plan d'audit").[H8].Value[/COLOR]
Range("N" & lig).Value =[COLOR="red"] audit[/COLOR]
With Wb.Sheets("ConstatsISO")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
[COLOR="red"]Range("N" & lig).Value = audit[/COLOR]
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

With Wb.Sheets("ConstatsISO22000")
For k = 8 To .[A65536].End(3).Row
If .Range("A" & k) <> "" Then
lig = [I65536].End(3).Row + 1
[COLOR="red"]Range("N" & lig).Value = audit[/COLOR]
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

With Wb.Sheets("ConstatsIFS")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
[COLOR="Red"]Range("N" & lig).Value = audit[/COLOR]
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
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
[COLOR="Red"]Range("N" & lig).Value = audit[/COLOR]
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
Next
End With
Wb.Close

End Sub

 

[thomasdu40]

Re : Macro réunissant fonctions recherche et extraction

Ca y est j'ai trouvé voici le code complet et définitif.

Sujet définitivement clôturé.

Private Sub CommandButton1_Click()
Dim Wb As Workbook
Feuil1.Select  'Feuil1(nom de gauche en projet)
chemin = "G:\S - ISO\A - Audits\"
fichier = TextBox1.Text & ".xls"
On Error Resume Next
Set Wb = GetObject(chemin & fichier)
If Err <> 0 Then MsgBox "Fichier Absent": Exit Sub
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

With Wb.Sheets("ConstatsISO22000")
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

With Wb.Sheets("ConstatsIFS")
For k = 6 To .[C65536].End(3).Row
If .Range("C" & k) <> "" Then
lig = [I65536].End(3).Row + 1
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
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
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
Next
End With
Wb.Close
End Sub