XL 2013 [Résolu]Dupliquer macro dans la même feuille

[Etn]

Bonjour,

Voici la macro que j'utilise pour extraire des colonnes d'une feuille, et vous trouverez ci-joint le classeur qui va avec (extraction données) :

Private Sub CommandButton21_Click()
Dim fich
[G4:G5] = "":
fich = Application.GetOpenFilename
If fich = False Then Exit Sub
[G4] = Left(fich, InStrRev(fich, "\"))
[G5] = Mid(fich, InStrRev(fich, "\") + 1)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [G4:G7]) Is Nothing Or Application.CountBlank([G4:G7]) Then Exit Sub
Dim dossier$, fich$, ext$, feuil$, zone$, r As Range, f$, col%, ad$, h&, h1&
dossier = [G4]
fich = [G5]
ext = Mid(fich, InStrRev(fich, "."))
feuil = [G6]
zone = [G7]
[A:D].ClearContents 'RAZ
If fich = ThisWorkbook.Name Then [G5] = "": Exit Sub
If Dir(dossier & fich) = "" Then MsgBox "Fichier introuvable...": Exit Sub
If Not ext Like ".xls*" Then MsgBox "Ce n'est pas un fichier Excel...": Exit Sub
On Error Resume Next
Set r = Range(Replace(zone, ";", ",")).EntireColumn
If r Is Nothing Then MsgBox "Revoir l'adressage des colonnes...": Exit Sub
Set r = Intersect(r, Rows(1))
If r.Count > 4 Then MsgBox "Maximum 4 colonnes...": Exit Sub
Application.ScreenUpdating = False
f = "'" & dossier & "[" & fich & "]" & feuil & "'!"
For Each r In r
  col = col + 1
  ad = r.EntireColumn.Address(ReferenceStyle:=xlR1C1)
  h = 0: h1 = 0
  h = ExecuteExcel4Macro("MATCH(9^9," & f & ad & ")")
  h1 = ExecuteExcel4Macro("MATCH(""zzz""," & f & ad & ")")
  h = Application.Min(IIf(h > h1, h, h1), Rows.Count)
  If h Then
  ad = r.Resize(h).Address(ReferenceStyle:=xlR1C1)
  With Cells(1, col).Resize(h)
  .FormulaArray = "=" & f & ad 'formule matricielle
  .Value = .Value 'supprime la formule
  End With
  End If
Next
End Sub

Néanmoins je souhaiterais dupliquer cette macro pour obtenir un 2e bouton dans la même feuille, que les données soient en colonne M par exemple et que l'extraction se fasse en colonnes P:S.

Pour dupliquer le bouton et afficher le nom du fichier il n'y a pas de problèmes, en revanche pour extraire les colonnes il y a toujours des erreurs (dues aux "dim" qui sont identiques je pense).

Vous pourrez trouver la forme que je cherche dans "modèle extraction"

Merci d'avance pour votre aide,

Etn.

 

[Hieu]

Oui,
te suffit d'ajouter une sortie de sub dans titi, sur la variable fich :

Sub titi(c As Range, col as integer) ' ici pour la modif
' If Intersect(Target, [G4:G7]) Is Nothing Or Application.CountBlank([G4:G7]) Then Exit Sub
Dim dossier$, fich$, ext$, feuil$, zone$, r As Range, f$, ad$, h&, h1& ' ici suppression de col%
dossier = c
fich = c.Offset(1, 0)
fich = c.Offset(1, 0): If fich = "" Then Exit Sub    ' < === ICI
ext = Mid(fich, InStrRev(fich, "."))
feuil = c.Offset(2, 0)
zone = c.Offset(3, 0)
[A:D].ClearContents 'RAZ
If fich = ThisWorkbook.Name Then c.Offset(1, 0) = "": Exit Sub
If Dir(dossier & fich) = "" Then MsgBox "Fichier introuvable...": Exit Sub
If Not ext Like ".xls*" Then MsgBox "Ce n'est pas un fichier Excel...": Exit Sub
On Error Resume Next
Set r = Range(Replace(zone, ";", ",")).EntireColumn
If r Is Nothing Then MsgBox "Revoir l'adressage des colonnes...": Exit Sub
Set r = Intersect(r, Rows(1))
If r.Count > 4 Then MsgBox "Maximum 4 colonnes...": Exit Sub
Application.ScreenUpdating = False
f = "'" & dossier & "[" & fich & "]" & feuil & "'!"
For Each r In r
  col = col + 1
  ad = r.EntireColumn.Address(ReferenceStyle:=xlR1C1)
  h = 0: h1 = 0
  h = ExecuteExcel4Macro("MATCH(9^9," & f & ad & ")")
  h1 = ExecuteExcel4Macro("MATCH(""zzz""," & f & ad & ")")
  h = Application.Min(IIf(h > h1, h, h1), Rows.Count)
If h Then
    ad = r.Resize(h).Address(ReferenceStyle:=xlR1C1)
   With Cells(1, col).Resize(h)
      .FormulaArray = "=" & f & ad 'formule matricielle
   .Value = .Value 'supprime la formule
End With
End If
Next
End Sub

Merci d'ajouter [RESOLU] à ton titre si c'est terminé, @+

 

[Etn]

Cela ne fonctionne pas, j'ai bien ajouté la ligne

fich = c.Offset(1, 0): If fich = "" Then Exit Sub

Mais l'erreur provient de la ligne suivante :

 ext = Mid(fich, InStrRev(fich, "."))

 

[Hieu]

Re,

J'ai bien vu l'erreur :

Sub titi(c As Range, col as integer) ' ici pour la modif
' If Intersect(Target, [G4:G7]) Is Nothing Or Application.CountBlank([G4:G7]) Then Exit Sub
Dim dossier$, fich$, ext$, feuil$, zone$, r As Range, f$, ad$, h&, h1& ' ici suppression de col%
dossier = c
fich = c.Offset(1, 0)
If fich = "" Then Exit Sub   ' < === ICI
ext = Mid(fich, InStrRev(fich, "."))
feuil = c.Offset(2, 0)
zone = c.Offset(3, 0)
[A:D].ClearContents 'RAZ
If fich = ThisWorkbook.Name Then c.Offset(1, 0) = "": Exit Sub
If Dir(dossier & fich) = "" Then MsgBox "Fichier introuvable...": Exit Sub
If Not ext Like ".xls*" Then MsgBox "Ce n'est pas un fichier Excel...": Exit Sub
On Error Resume Next
Set r = Range(Replace(zone, ";", ",")).EntireColumn
If r Is Nothing Then MsgBox "Revoir l'adressage des colonnes...": Exit Sub
Set r = Intersect(r, Rows(1))
If r.Count > 4 Then MsgBox "Maximum 4 colonnes...": Exit Sub
Application.ScreenUpdating = False
f = "'" & dossier & "[" & fich & "]" & feuil & "'!"
For Each r In r
  col = col + 1
  ad = r.EntireColumn.Address(ReferenceStyle:=xlR1C1)
  h = 0: h1 = 0
  h = ExecuteExcel4Macro("MATCH(9^9," & f & ad & ")")
  h1 = ExecuteExcel4Macro("MATCH(""zzz""," & f & ad & ")")
  h = Application.Min(IIf(h > h1, h, h1), Rows.Count)
If h Then
    ad = r.Resize(h).Address(ReferenceStyle:=xlR1C1)
   With Cells(1, col).Resize(h)
      .FormulaArray = "=" & f & ad 'formule matricielle
  .Value = .Value 'supprime la formule
End With
End If
Next
End Sub

Une erreur, corrigée, je l'espere

 

[Etn]

Toujours le même problème qui vient de la ligne

ext = Mid(fich, InStrRev(fich, "."))

 

[Hieu]

Voici ce que j'ai fait; y a pas de problème, chez moi...

Peux-tu livrer ton dernier "jus" ?

 

[Etn]

Au temps pour moi, dans mon fichier j'avais le nom de mon fichier qui était égal à une autre cellule. Quand j'annulais la recherche de fichier cela marquait 0 dans les cellules où la macro allait chercher le fichier (du coup comme il n'y avait pas de fichier qui se nommait 0 alors y avait le message d'erreur).
Je sais pas si j'ai été très clair, bref j'ai juste mis =SI(G4=0;"";G4) et maintenant tout fonctionne correctement.

Merci encore pour toute ton aide Hieu !!

Bonne journée et bonne continuation.