selection multi-fichiers a partir d'un USF

[hurricane]

Bonsoir a tous

j'ai fait une rapide recherche dans les archives mais j'ai pas trouvé mon bonheur ou j'ai mal cherché

voici mon probleme:

je voudrais depuis un USF selectionner des fichiers dans un repertoire ' X '

puis j'ouvrir un fichier ' X1 ' je copie la plage ' A1: A20 ' je colle la plage dans une fichier ' Y ' en A1 : A20 je ferme le fichier ' X1 '

j'ouvre le fichier ' X2 ' je copie la plage ' A1 : A20 ' je colle la plage dans le fichier ' Y ' en ' B1 : B20 ' je ferme le fichier ' X2 '

etc etc ...

Voila si quelqu'un a un exemple sur la multi selection ds un USF je suis preneur

merci d'avance

 

[MichelXld]

bonsoir Hurricane

cet exemple permet de sélectionner plusieurs classeurs dans un répertoire en utilisant la boite de dialogue 'Ouvrir' d'Excel
ensuite la procédure boucle sur les classeurs sélectionnés récupère le nom de la premiere feuille dans les classeurs fermés et importe les données . les valeurs de la plage A1:A20 sont ajoutées dans la feuille active

attention cette macro ne gère pas les erreurs si un fichier d'un autre type qu'Excel est sélectionné
testé avec Excel2002



Sub importDonneesClasseursMultiSelection()
'necessite d'activer la reference Microsoft ActiveX Data Objects x.x Library
'necessite d 'activer la reference Microsoft ADO Ext 2.7 for DLL ans Security

Dim Cn As ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim Cat As ADOX.Catalog
Dim Fichier As FileDialog
Dim xConnect As String, Feuille As String
Dim Destination As String, Classeur As String, Cible As String
Dim Source() As String
Dim i As Byte, j As Byte

On Error GoTo Fin

Set Fichier = Application.FileDialog(msoFileDialogOpen) 'boite de dialogue 'Ouvrir'
Fichier.FilterIndex = 3 'filtrer pour n'afficher que les classeurs Excel(adapter si necessaire)
Fichier.Show
If Fichier.SelectedItems.Count = 0 Then Exit Sub 'sortir si aucun fichier n'est sélectionné


For i = 1 To Fichier.SelectedItems.Count 'boucler sur les classeurs sélectionnés

xConnect = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' & Fichier.SelectedItems(i) & ';' & _
'Extended Properties=Excel 8.0;' 'preparation connection

Set Cat = CreateObject('ADOX.Catalog')
Set Cn = CreateObject('ADODB.Connection')

Cn.Open xConnect
Set Cat.ActiveConnection = Cn

Feuille = Cat.tables(0).Name 'nom de la 1ere feuille dans le classeur fermé

Cible = 'SELECT * FROM [' & Feuille & '];'

Set Rs = New ADODB.Recordset
Rs.Open Cible, Cn, adOpenForwardOnly, adLockReadOnly, adCmdText

If Not Rs.EOF Then
Rs.MoveFirst

Cells(1, i) = Rs.Fields(0).Name 'entete colonne A ( cellule A1 )

For j = 2 To 20 ' import des autres cellules : plage A2:A20
If Rs.EOF Then Exit For 'au cas ou il y aurait moins de 20 données dans le classeur fermé
Cells(j, i) = Rs.Fields(0).Value
Rs.MoveNext
Next

End If

Rs.Close
Set Rs = Nothing
Set Cn = Nothing
Set Cat = Nothing
Next i

Exit Sub
Fin:
Rs.Close
Set Rs = Nothing
Set Cn = Nothing
Set Cat = Nothing
End Sub


bonne soiree
MichelXld

 

[hurricane]

bonjour michelxld

desolé pour le retard de ma reponse mais j'etais deconnecté en attendant d'etre reconnecté j'etais parti sur autre chose qui ne fonctionne pas mais qui me semble interessant.
une question
Dans une listbox en multiselect comment vba gére l'ouverture des fichiers un à un ou il veut ouvrir tous les fichiers en meme temps ?

ci joint le code:
Option Explicit

Dim Adresse As String
Const Titre As String = 'xxxxxxxxxxxxxxxx'


Private Sub UserForm_Initialize()
Dim ThisBookPath As String
Dim ChercheFichier As FileSearch
Dim I As Integer
On Error Resume Next
Me.Caption = Titre

Set ChercheFichier = Application.FileSearch
ThisBookPath = ThisWorkbook.Path
Adresse = 'I:\\xxxxxxxxxxxxxx\\yyyyyyyy\\zzzzzzzzzz' '<---ici modif du repertoire pour importer les données

Label2 = Adresse

With ChercheFichier
.NewSearch
.Filename = '*.xls'
.LookIn = Adresse
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
ListBox1.AddItem Dir(.Item(I))
Next I
ListBox1.MultiSelect = fmMultiSelectMulti
End With
Else
MsgBox 'Pas de N° de contrôle dans ' & Adresse
End If
End With
End Sub

Private Sub CommandButton1_Click()

Dim I As Integer
Dim colonnefin As Long
Dim Wb As Workbook

If ListBox1.ListIndex = -1 Then Exit Sub

Set Wb = Workbooks.Open(Filename:=Adresse & '\\' & ListBox1)
Sheets('aaa').Range('T18:T46').Copy
Windows('tttttttttttttt.xls').Activate
Sheets('VVVV').Select
colonnefin = Range('IV2').End(xlToLeft).Column
Cells(2, colonnefin + 1).Select
ActiveSheet.Paste

Windows(ListBox1.Value).Activate
Sheets('fffffffff').Range('T10:T42').Select
Selection.Copy
Windows('tttttttttttttt.xls').Activate
Sheets('VVVVV').Select
colonnefin = Range('IV2').End(xlToLeft).Column
Cells(2, colonnefin + 1).Select
ActiveSheet.Paste

Wb.Close savechanges:=False
Unload Me
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

le code coince apres le commandbutton1.

Si tu penses qu'il n'y a pas de solution avec ce genre de code je repars avec ton code et j'essaie de l'adapter a mes besoins

merci et encore desolé pour le retard

@+