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é
Salut,

Essaie ceci :
VB:
Private Sub CommandButton1_Click()
Call toto([G4:G5], [G4], [G5])
End Sub

Private Sub CommandButton21_Click()
Call toto([K4:K5], [K4], [K5])
End Sub

Et dans un module :
VB:
Sub toto(plage, c1, C2)
Dim fich
plage = ""
fich = Application.GetOpenFilename
If fich = False Then Exit Sub
c1 = Left(fich, InStrRev(fich, "\"))
C2 = Mid(fich, InStrRev(fich, "\") + 1)
End Sub
 

Pièces jointes

  • modèle extraction_v0.xlsm
    42.5 KB · Affichages: 69

Etn

XLDnaute Occasionnel
Bonjour Hieu !

Tout d'abord merci pour ton aide.

J'ai essayé d'utiliser ta pièce jointe, mais impossible d'obtenir l'extraction des données (en colonne A:C ou N:p) quand je sélectionne un fichier à l'aide d'un bouton (rien ne se passe).

Bonne journée,

Etn
 

Hieu

XLDnaute Impliqué
Salut,

J'ai modifié la sub toto (juste en rajoutant les dimensions des variables) et ça semble marcher ;
VB:
Sub toto(plage as Range, c1 as Range, C2 as Range) ' <=========== ici
Dim fich
plage = ""
fich = Application.GetOpenFilename
If fich = False Then Exit Sub
c1 = Left(fich, InStrRev(fich, "\"))
C2 = Mid(fich, InStrRev(fich, "\") + 1)
End Sub
 

Pièces jointes

  • modèle extraction_v1.xlsm
    45.8 KB · Affichages: 65

Etn

XLDnaute Occasionnel
Salut,

Je suis vraiment désolé mais cela ne fonctionne pas chez moi.

Si j'ai bien compris la logique, tu répètes la macro toto en fonction du bouton activé ==> Le chemin et le nom du fichier apparaissent bien en G4:G5 et en K4:K5.

Maintenant au niveau de l'extraction cela ne fonctionne que pour le bouton 1 (extraction des colonnes A:A;D:D;P:p du fichier externe).

Cela est dû (je suppose) à la macro du code de la feuille qui ne s'applique que pour dossier = G4 et fichier = G5 :

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

Je pense qu'il faudrait la dupliquer également pour qu'elle aille également chercher le dossier en K4 et le fichier en K5 (et la feuille en K6, etc).

Le problème est là, je n'y parviens pas. Cela peut il fonctionner si je recopie le code à la suite et que je remplace les données G4 par K4 par exemple ?

Bonne journée,

Etn
 

Hieu

XLDnaute Impliqué
Au temps pour moi, je n'avais pas vu que cette macro tournait dû aux boutons; par contre je ne comprends pas pourquoi avoir fait un évènement ?
Personnellement, je le ferai suivant une subroutine qui se fait appeler dans les boutons;

VB:
Private Sub CommandButton1_Click()
Call toto([G4:G5], [g4], [G5])
Call titi([g4])
End Sub

Private Sub CommandButton21_Click()
Call toto([K4:K5], [k4], [k5])
Call titi([k4])
End Sub

et la subroutine titi :
VB:
Sub titi(c 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 = c
fich = c.Offset(1, 0)
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
 

Pièces jointes

  • modèle extraction_v2.xlsm
    43.6 KB · Affichages: 63

Etn

XLDnaute Occasionnel
Bonjour !

Super la nouvelle macro, on se rapproche de ce que je souhaite (à un détail près) : Je souhaiterais que l'extraction du bouton 2 se fasse en N:Q et non en A:D.

On aurait ainsi les deux extractions visibles (celle du bouton 1 en A:D et celle du bouton 2 en N:Q)
 

Etn

XLDnaute Occasionnel
Et bien je dirais que c'est dans cette partie :

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

Et tout ce qui est avant permet de définir les variables :

VB:
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 & "'!"

Mais ce n'est que supposition (je suis nul en vba désolé...)
 

Hieu

XLDnaute Impliqué
Ok,

Tu n'es pas l'initiateur du programme ; Depuis le début, je navigue à l'aveuglette.
En regardant de plus près, il semblerait qu'il ne faille que remplir la cellule K7 sur ta feuille excel ;

Bouton 1 : cellule G7 (=A: A;D: D;P: P)
Bouton 2 : cellule K7 (=N:N; Q: Q)

et ça marche ?
 

Etn

XLDnaute Occasionnel
Effectivement ce n'est pas moi (désolé).

Alors l'extraction s'exécute quand l'une des 4 cellules (G4:G7) est actualisée (d'où le worksheet change).

Les cellules G7 et K7 sélectionnent les colonnes à extraire dans le fichier source, ce ne sont pas les colonnes où vont être copiées les données.

Le problème c'est qu'aucune macro ne s'active quand on rafraichit les cellules K4:K7 (ce qui semble normal car à aucun moment dans la macro on ne fait mention de ces cellules).

En terme de résultat ce que je recherche, c'est avoir exactement la même macro que pour l'extraction en colonnes A: D du fichier sélectionné en G4:G7, mais pour le fichier sélectionné en K4:K7 et l'extraction se fait en N:Q
 

Hieu

XLDnaute Impliqué
Ok, il semblerait que ce soit le parametre col qui fait ca.
VB:
Private Sub CommandButton1_Click()
Call toto([G4:G5], [g4], [G5])
Call titi([g4], 0)    ' 0 car en ajoutant 1 on arrive à la colonne A
End Sub

Private Sub CommandButton21_Click()
Call toto([K4:K5], [k4], [k5])
Call titi([k4], 13)     ' 13 car en ajoutant 1 on arrive à la colonne N
End Sub

Et titi :
VB:
Sub titi(c As Range, col)
' 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 = c
fich = c.Offset(1, 0)
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
 

Pièces jointes

  • modèle extraction_v3.xlsm
    42.4 KB · Affichages: 69

Hieu

XLDnaute Impliqué
ah oui, au temps pour moi.
Il faut supprimer le déclaration de col :
modifie titi par :
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)
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

Ligne 1 et 3
 

Etn

XLDnaute Occasionnel
Super !
Merci beaucoup Hieu pour tout le temps que tu as passé pour t'occuper de mon problème !

J'ai modifié le [A: D].ClearContents dans titi et je les ai mis directement dans la feuille. De plus j'ai rajouté un 3e bouton et ça marche impec !

VB:
Private Sub CommandButton1_Click()
Call toto([G4:G5], [g4], [g5])
[A:D].ClearContents
Call titi([g4], 0)
End Sub

Private Sub CommandButton21_Click()
Call toto([K4:K5], [k4], [k5])
[N:P].ClearContents
Call titi([k4], 13)
End Sub

Private Sub CommandButton22_Click()
Call toto([G13:G14], [g13], [g14])
[R:T].ClearContents
Call titi([g13], 17)
End Sub

Edit : Quand on clique sur un bouton pour choisir le fichier, puis qu'on annule un message d'erreur apparait : "Argument ou appel de procédure incorrect".
C'est possible de juste quitter la sub sans aucun message ?
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 729
Messages
2 081 971
Membres
101 852
dernier inscrit
dthi16088