XL 2013 Lire plage cellule classeur fermé

[Etn]

Bonjour,

Je souhaiterais lire une plage d'un classeur fermé (du Classeur1 ci-joint).

Pour cela j'ai fait quelques recherches et je suis tombé sur le site de boisgontierjacques qui me propose le code ci dessous (vous pouvez le retrouver dans le fichier que j'ai joint) :

Sub Lit()

  x = LitUneCellule("c:\mesdoc\excelmacronouveau\1001exemples", "ADOsource.xls", "feuil1", "A4")

  MsgBox x

End Sub



Function LitUneCellule(repertoire As String, fichier As String, feuille As String, cellule As String)

  'Microsoft ActiveX DataObject 2.8 doit être coché

  Application.Volatile

  Set cnn = New ADODB.Connection

  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _

  "Data Source=" & repertoire & "\" & fichier & _

  ";Extended Properties=""Excel 8.0;HDR=No;"";"

  Set rs = cnn.Execute("SELECT * FROM [" & feuille & "$" & cellule & ":" & cellule & "]")

  LitUneCellule = rs(0)

  rs.Close

  cnn.Close

  Set rs = Nothing

  Set cnn = Nothing

End Function



Sub Ecrit()

  Call ModifieUneCellule("c:\mesdoc\excelmacronouveau\1001exemples", "ADOsource.xls", "feuil1", "A4", "totox")

End Sub



Sub ModifieUneCellule(repertoire As String, fichier As String, feuille As String, cellule As String, NouvelleValeur)

  'Microsoft ActiveX DataObject 2.8 doit être coché

  Set cnn = New ADODB.Connection

  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _

  "Data Source=" & repertoire & "\" & fichier & _

  ";Extended Properties=""Excel 8.0;HDR=No;"";"

  Sql = "SELECT * FROM [" & feuille & "$" & cellule & ":" & cellule & "]"

  Set rs = New ADODB.Recordset

  rs.Open Sql, cnn, adOpenDynamic, adLockOptimistic

  rs(0).Value = NouvelleValeur

  rs.Update

  rs.Close

  cnn.Close

  Set rs = Nothing

  Set cnn = Nothing

End Sub

Cela me permet de lire une cellule dans le fichier Classeur1 (joint).
Cependant je souhaiterais savoir comment modifier la macro pour :
-Lire une plage de cellule définie
-Lire une plage de cellule définie dans plusieurs classeurs
-Lire des classeurs xlsx et xlsm (et pas uniquement xls comme c'est actuellement).

Tout est expliqué dans le "Fichier recherché" ci-joint avec en Feuil1 la feuille utilisant la macro, et dans "Résultat idéalement voulu" ce que je souhaiterais obtenir à la fin.

Merci pour votre aide.
Etn

 

[job75]

Bonsoir Etn,

S'il s'agit de copier un classeur à la fois, le plus simple est de l'ouvrir.

Voyez le fichier joint et ces macros :

Private Sub CommandButton1_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, w As Worksheet
dossier = [G4]
fich = [G5]
ext = Mid(fich, InStrRev(fich, "."))
feuil = [G6]
zone = [G7]
[A:D].Clear
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
If Intersect(r, Rows(1)).Count > 4 Then MsgBox "Maximum 4 colonnes...": Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set w = Workbooks.Open(dossier & fich).Sheets(feuil)
If w Is Nothing Then MsgBox "Feuille inexistante..."
w.Range(r.Address).Copy [A1]
w.Parent.Close
End Sub

Le bouton permet de choisir facilement le fichier mais on n'est pas obligé de l'utiliser.

Bonne fin de soirée.

 

[Etn]

Bonjour job75,

Tout d'abord merci pour ta réponse.
Il est vrai que je n'avais pas pensé à ouvrir le fichier puis le refermer.
J'ai essayé ton fichier, il marche parfaitement, malheureusement quand le fichier source comporte un filtre il ne prend que les données filtrées et pas la totalité (même si je me doute que en 2 lignes tu dois pouvoir rajouter un "If filtre on then filtre off" (j'y connais rien mais je suppose que ça doit être l'idée).

J'ai tout de même trouvé une solution de mon côté (pas parfaite je le conçois).

Cela consiste à copier une plage entière dans une première feuille, puis d'extraire les colonnes recherchées dans une 2e feuille (appelée BDD). Il n'y a pas besoin d'ouvrir le fichier (donc pas de message "êtes vous sûrs de vouloir ouvrir ce fichier").

En tout cas merci de ton aide, je suis certain que ton fichier me sera utile, le fait qu'il prenne en compte les filtres et que tu puisses choisir le fichier avec un bouton est un plus !

Bonne journée, Etn

 

[job75]

Bonjour Etn,

En effet si la feuille à copier est filtrée il suffit de tout afficher :

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

La méthode avec ExecuteExcel4Macro (formule de liaison) est plus simple que la méthode ADO.

Mais bien sûr les formats ne sont pas copiés.

A+

 

[Etn]

Bonjour,

En effet la dernière macro répond parfaitement à mes attentes.
Donc, comparé à ADO, il n'y a pas besoin d'activer 'Microsoft ActiveX DataObject 2.8' n'est-ce pas ?

 

[job75]

Re,

Non ce nest pas nécessaire.

Je viens de faire une petite modif dans le 2ème fichier du post #4, utilisez la bonne version.

A+

 

[Etn]

Re,

Ok merci beaucoup pour votre aide.

Juste par curiosité, je n'utilisais plus la macro ADO, mais une bien plus simple :

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" Then
  ChampOuCopier = "A5:K305"
  Chemin = [B3]
  Fichier = [B2]
  onglet = [B1]
  ChampAlire = "L1:V300"
  LitChamp ChampOuCopier, Chemin, Fichier, onglet, ChampAlire
  End If
End Sub
Sub LitChamp(ChampOuCopier, Chemin, Fichier, onglet, ChampAlire)
  Range(ChampOuCopier).FormulaArray = "='" & Chemin & "\[" & Fichier & "]" & onglet & "'!" & ChampAlire
  Range(ChampOuCopier) = Range(ChampOuCopier).Value
End Sub

Ce n'est pas du ADO, et l'exécution de la macro est plus rapide que celle que vous m'avez proposé (mais moins de possibilités c'est indéniable).
La différence de vitesse réside dans le fait que votre macro propose plusieurs messages en cas de fichiers incorrects ? Ou c'est le fait d'utiliser du Excel4macro ? Et pourquoi utiliser du Excel4macro plutôt que du vba tout court (comme ce que j'ai ci-dessus je suppose) ?

Etn.

 

[job75]

Re,

Votre méthode est la même que la mienne.

Mais moi j'utilise en plus ExecuteExcel4Macro pour déterminer la hauteur h de la plage à copier.

A+

 

[Etn]

Ah oui en effet ! Atout non négligeable !

Bien, en tout cas merci encore pour votre aide et je vous souhaite une bonne journée !

Etn.