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

Etn

XLDnaute Occasionnel
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) :

VB:
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.
 

Pièces jointes

  • extraction données.xlsm
    43.5 KB · Affichages: 108
  • modèle extraction.xlsm
    44.1 KB · Affichages: 91

Hieu

XLDnaute Impliqué
Oui,
te suffit d'ajouter une sortie de sub dans titi, sur la variable fich :
VB:
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é, @+
 

Hieu

XLDnaute Impliqué
Re,

J'ai bien vu l'erreur :
VB:
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

XLDnaute Occasionnel
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.
 

Discussions similaires

Réponses
4
Affichages
401
Réponses
7
Affichages
486
Réponses
9
Affichages
284

Statistiques des forums

Discussions
314 450
Messages
2 109 719
Membres
110 551
dernier inscrit
Khyolyanna