29. november 2007 - 13:05Der er
11 kommentarer og 1 løsning
Hente filnavn ind i en dropdownliste.
Hej,
Kan man lave en dropdownliste i Excel hvor den hvis alle de filer der ligger i en bestemt mappe? og når man så markere et filnavn på droplisten skal den hive filnavet med tilbage til den celle hvor man trykkede på dropdownlisten...
Denne kode, laver en tabel med alle de *.xls der findes i samme mappe som den åbent fil, såvidt jeg kan se er du nød til at have en knappe til at opdatere den med
I din dropdown kan vælge tabel A2:A1000, og celle resultat i linked celle
Private Sub CommandButton1_Click() Dim FS As FileSearch Dim FilePath As String, FileSpec As String Dim i As Long Dim v As Variant Dim rTarget As Range Dim ToSheet As Worksheet Dim Data As Variant '****************************** FilePath = "\\" 'FilePath = "D:\Documents and Settings\jml\My Documents" FileSpec = "*.xls" Set ToSheet = ThisWorkbook.Worksheets("sheet1") '****************************** 'find excel filerne Set FS = Application.FileSearch With FS .LookIn = FilePath .Filename = FileSpec .SearchSubFolders = False 'skal underfoldere også søges .Execute If .FoundFiles.Count = 0 Then MsgBox ("Ingen filer fundet") Exit Sub End If End With Range("A1:A1000").ClearContents Range("A1") = "antal filer:" Range("B1") = FS.FoundFiles.Count For i = 1 To FS.FoundFiles.Count Set rTarget = ToSheet.Range("A1000").End(xlUp).Offset(1, 0) For t = 1 To Len(FS.FoundFiles(i)) If Mid(FS.FoundFiles(i), t, 1) = "\" Then sidst = t Next t rTarget.Offset(0, 0) = Mid(FS.FoundFiles(i), sidst + 1, Len(FS.FoundFiles(i)) - sidst) Next i End Sub
Denne opdatere liste hvergang musen kommer over dropdown
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Call listefil End Sub
Private Sub listefil() Dim FS As FileSearch Dim FilePath As String, FileSpec As String Dim i As Long Dim v As Variant Dim rTarget As Range Dim ToSheet As Worksheet Dim Data As Variant '****************************** FilePath = "\\" 'FilePath = "D:\Documents and Settings\jml\My Documents" FileSpec = "*.xls" Set ToSheet = ThisWorkbook.Worksheets("sheet1") '****************************** 'find excel filerne Set FS = Application.FileSearch With FS .LookIn = FilePath .Filename = FileSpec .SearchSubFolders = False 'skal underfoldere også søges .Execute If .FoundFiles.Count = 0 Then MsgBox ("Ingen filer fundet") Exit Sub End If End With Range("A1:A1000").ClearContents Range("A1") = "antal filer:" Range("B1") = FS.FoundFiles.Count For i = 1 To FS.FoundFiles.Count Set rTarget = ToSheet.Range("A1000").End(xlUp).Offset(1, 0) For t = 1 To Len(FS.FoundFiles(i)) If Mid(FS.FoundFiles(i), t, 1) = "\" Then sidst = t Next t rTarget.Offset(0, 0) = Mid(FS.FoundFiles(i), sidst + 1, Len(FS.FoundFiles(i)) - sidst) Next i End Sub
Det passer ikke helt det jeg skrev, den tager standard bibliotektet, denne her tager den folder som den nuværende fil er gemt i
Sub filliste() Dim FS As FileSearch Dim FilePath As String, FileSpec As String Dim i As Long, t As Integer Dim v As Variant Dim rTarget As Range Dim ToSheet As Worksheet '****************************** 'FilePath = "\\" FilePath = ThisWorkbook.Path 'FilePath = "D:\Documents and Settings\jml\My Documents" FileSpec = "*.xls" Set ToSheet = ThisWorkbook.Worksheets("sheet1") '****************************** 'find excel filerne Set FS = Application.FileSearch With FS .LookIn = FilePath .Filename = FileSpec .SearchSubFolders = False 'skal underfoldere også søges .Execute If .FoundFiles.Count = 0 Then MsgBox ("Ingen filer fundet") Exit Sub End If End With Range("A1:A1000").ClearContents Range("A1") = "antal filer:" Range("B1") = FS.FoundFiles.Count For i = 1 To FS.FoundFiles.Count For t = 1 To Len(FS.FoundFiles(i)) If Mid(FS.FoundFiles(i), t, 1) = "\" Then sidst = t Next t ToSheet.Range("A1").Offset(i, 0) = Mid(FS.FoundFiles(i), sidst + 1, Len(FS.FoundFiles(i)) - sidst) Next i End Sub
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.