Astuces Excel
  1. Astuces Excel
  3. Excel VBA: Créer une list de tous les files dans un dossier, y compris des liens hypertext et copyr des données à partir de chaque file Excel qu'il trouve
Intereting Posts
Excel, Trying Index, Match, pour searchr des valeurs avec VBA Je veux créer quelque chose qui va essentiellement "IF Q = O ALLEN DELETE Q" Remplacer datatables existantes par une nouvelle donnée C # OleDbCommand text: caractères spéciaux et reference de gamme Excel Comment puis-je conditionnellement formater les cellules en fonction d'une formule indirecte qui fait reference aux cellules "en mouvement" comment extraire le file Excel et afficher la sortie sur le countur de vitesse Exécution d'une macro sur un autre file Excel Limiter l'édition d'en-tête dans Excel Essayer d'exécuter SP dans excel (macro vba) plusieurs fois La requête T-SQL avec les déclarations de variables dans Excel VBA Code fail Comment forcer le return du type de données lors de l'interrogation sur Excel de Powershell? GETPIVOTDATA et autres feuilles de travail Bouclez la colonne, searchz le text Power Pivot est-il multidimensionnel? Comment éviter de répéter le même bloc de formule n fois

Excel VBA: Créer une list de tous les files dans un dossier, y compris des liens hypertext et copyr des données à partir de chaque file Excel qu'il trouve

Ma première publication ici, alors soyez doux 🙂

Voici la situation. Je travaille sur un grand logiciel comme softwartister. En ce moment, nous commençons par une énorme révision de l'application qui aboutit à beaucoup de files Excel avec testcases et rapports d'état (plus de 200 files dans les mois à venir). Pour suivre la progression de tout ce dont nous avons besoin, une feuille de pathée qui peut faire une list de tous les files, y compris des liens hypertext, et lire les informations d'état de chaque file lorsqu'il existe.

J'ai trouvé beaucoup de tutoriels pour créer une list de tous les files dans un dossier et leur donner des hyperliens. Actuellement, j'utilise le code de ce site: http://www.vbaexpress.com/kb/getarticle.php?kb_id=232

Donc maintenant, je peux faire une list de tous les files dans le dossier que je peux sélectionner à partir d'un écran pop-up. 

Option Compare Text Option Explicit Function Excludes(Ext As Ssortingng) As Boolean 'Function purpose: To exclude listd file extensions from hyperlink listing Dim X, NumPos As Long 'Enter/adjust file extensions to EXCLUDE from listing here: X = Array("exe", "bat", "dll", "zip", "txt", "xlsm", "html", "htm", "xml") On Error Resume Next NumPos = Application.WorksheetFunction.Match(Ext, X, 0) If NumPos > 0 Then Excludes = True On Error GoTo 0 End Function Sub HyperlinkFileList() 'Macro purpose: To create a hyperlinked list of all files in a user 'specified directory, including file size and date last modified 'NOTE: The 'TextToDisplay' property (of the Hyperlink object) was added 'in Excel 2000. This code tests the Excel version and does not use the 'Texttodisplay property if using XL 97. Dim fso As Object, _ ShellApp As Object, _ File As Object, _ SubFolder As Object, _ Directory As Ssortingng, _ Problem As Boolean, _ ExcelVer As Integer 'Turn off screen flashing Application.ScreenUpdating = False ' Clear sheet Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select 'Create objects to get a listing of all files in the directory Set fso = CreateObject("Scripting.FileSystemObject") 'Prompt user to select a directory Do Problem = False Set ShellApp = CreateObject("Shell.Application"). _ Browseforfolder(0, "Please choose a folder", 0, "D:") 'Browseforfolder(0, "Please choose a folder", 0, "D:\JBOSS\Testdossier") On Error Resume Next 'Evaluate if directory is valid Directory = ShellApp.self.Path Set SubFolder = fso.GetFolder(Directory).Files If Err.Number <> 0 Then If MsgBox("You did not choose a valid directory!" & vbCrLf & _ "Would you like to try again?", vbYesNoCancel, _ "Directory Required") <> vbYes Then Exit Sub Problem = True End If On Error GoTo 0 Loop Until Problem = False 'Set up the headers on the worksheet With ActiveSheet With .Range("A1") .Value = "Listing of all files in:" .ColumnWidth = 40 'If Excel 2000 or greater, add hyperlink with file name 'displayed. If earlier, add hyperlink with full path displayed If Val(Application.Version) > 8 Then 'Using XL2000+ .Parent.Hyperlinks.Add _ Anchor:=.Offset(0, 1), _ Address:=Directory, _ TextToDisplay:=Directory Else 'Using XL97 .Parent.Hyperlinks.Add _ Anchor:=.Offset(0, 1), _ Address:=Directory End If End With With .Range("A2") .Value = "File Name" .Interior.ColorIndex = 15 .ColumnWidth = 50 With .Offset(0, 1) .ColumnWidth = 15 .Value = "Date Modified" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 2) .ColumnWidth = 12 .Value = "File Size (Kb)" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 3) .ColumnWidth = 18 .Value = "Status testdossier" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 4) .ColumnWidth = 22 .Value = "Totaal aantal testgevallen" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 5) .ColumnWidth = 15 .Value = "Uitgevoerd" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 6) .ColumnWidth = 15 .Value = "Akkoord" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 7) .ColumnWidth = 6 .Value = "OK" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 8) .ColumnWidth = 6 .Value = "NOK" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With End With End With 'Adds each file, details and hyperlinks to the list For Each File In SubFolder If Not Excludes(Right(File.Path, 3)) = True Then With ActiveSheet 'If Excel 2000 or greater, add hyperlink with file name 'displayed. If earlier, add hyperlink with full path displayed If Val(Application.Version) > 8 Then 'Using XL2000+ .Hyperlinks.Add _ Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _ Address:=File.Path, _ TextToDisplay:=File.Name Else 'Using XL97 .Hyperlinks.Add _ Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _ Address:=File.Path End If 'Add date last modified, and size in KB With .Range("A65536").End(xlUp) .Offset(0, 1) = File.datelastModified With .Offset(0, 2) .Value = WorksheetFunction.Round(File.Size / 1024, 1) .NumberFormat = "#,##0.0" End With End With 'Add Total From this file to current workbook With .Range("A65536").End(xlUp) .Offset(0, 4) = End With End With End If Next End Sub

J'ai cependant quelques problèmes 🙁 Le numéro un est qu'il n'exclut pas toutes les extensions de file que j'ai mises ici … par exemple .bat ne sera pas sélectionné, mais .txt et .xlsm le feront. Je ne sais pas comment réparer cela.

Le numéro deux est que je ne sais pas comment copyr les informations des files excel qui sont listés. Je pense que cela doit être fait à la partie suivante presque au bas "" Ajoute chaque file, les détails et les liens hypertext à la list "Au dernier" avec "j'essaie d'get datatables du file jusqu'à présent. ne créez rien 🙁 Les ​​données que j'essaye de récupérer sont des nombres dans quelques champs sur la première feuille de chaque classur.

Je pense que le code doit venir après ".Offset (0, 4)" mais aidez-moi!

Cela devrait vous aider: 

 Option Compare Text Option Explicit Function Excludes(Ext As Ssortingng) As Boolean 'Function purpose: To exclude listd file extensions from hyperlink listing Dim X, NumPos As Long 'Enter/adjust file extensions to EXCLUDE from listing here: X = Array("exe", "bat", "dll", "zip", "txt", "xlsm", "html", "htm", "xml") On Error Resume Next NumPos = Application.WorksheetFunction.Match(Ext, X, 0) If NumPos > 0 Then Excludes = True Else Excludes = False End If On Error GoTo 0 End Function

Pour les filters d'extensions, vérifiez votre ancienne fonction, mais je suis plutôt sûr qu'il n'y avait aucun return «faux» car vous ne l'avez pas configuré dans votre code.

Ensuite, vous devez ouvrir le classur pour en retirer des données: 

 Sub HyperlinkFileList() 'Macro purpose: To create a hyperlinked list of all files in a user 'specified directory, including file size and date last modified 'NOTE: The 'TextToDisplay' property (of the Hyperlink object) was added 'in Excel 2000. This code tests the Excel version and does not use the 'Texttodisplay property if using XL 97. Dim fso As Object, _ ShellApp As Object, _ File As Object, _ SubFolder As Object, _ Directory As Ssortingng, _ Problem As Boolean, _ ExcelVer As Integer, _ TotalD As Ssortingng, _ Wb As Workbook, _ Ws As Worksheet 'Turn off screen flashing Application.ScreenUpdating = False ' Clear sheet Cells.Delete Shift:=xlUp 'Useless : Range("A1").Select 'Create objects to get a listing of all files in the directory Set fso = CreateObject("Scripting.FileSystemObject") 'Prompt user to select a directory Do Problem = False Set ShellApp = CreateObject("Shell.Application"). _ Browseforfolder(0, "Please choose a folder", 0, "D:") 'Browseforfolder(0, "Please choose a folder", 0, "D:\JBOSS\Testdossier") On Error Resume Next 'Evaluate if directory is valid Directory = ShellApp.self.Path Set SubFolder = fso.GetFolder(Directory).Files If Err.Number <> 0 Then If MsgBox("You did not choose a valid directory!" & vbCrLf & _ "Would you like to try again?", vbYesNoCancel, _ "Directory Required") <> vbYes Then Exit Sub Problem = True End If On Error GoTo 0 Loop Until Problem = False 'Set up the headers on the worksheet With ActiveSheet With .Range("A1") .Value = "Listing of all files in:" .ColumnWidth = 40 'If Excel 2000 or greater, add hyperlink with file name 'displayed. If earlier, add hyperlink with full path displayed If Val(Application.Version) > 8 Then 'Using XL2000+ .Parent.Hyperlinks.Add _ Anchor:=.Offset(0, 1), _ Address:=Directory, _ TextToDisplay:=Directory Else 'Using XL97 .Parent.Hyperlinks.Add _ Anchor:=.Offset(0, 1), _ Address:=Directory End If End With With .Range("A2") .Value = "File Name" .Interior.ColorIndex = 15 .ColumnWidth = 50 With .Offset(0, 1) .ColumnWidth = 15 .Value = "Date Modified" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 2) .ColumnWidth = 12 .Value = "File Size (Kb)" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 3) .ColumnWidth = 18 .Value = "Status testdossier" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 4) .ColumnWidth = 22 .Value = "Totaal aantal testgevallen" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 5) .ColumnWidth = 15 .Value = "Uitgevoerd" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 6) .ColumnWidth = 15 .Value = "Akkoord" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 7) .ColumnWidth = 6 .Value = "OK" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 8) .ColumnWidth = 6 .Value = "NOK" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With End With End With 'Adds each file, details and hyperlinks to the list For Each File In SubFolder If Not Excludes(Right(File.Path, 3)) = True Then With ActiveSheet 'If Excel 2000 or greater, add hyperlink with file name 'displayed. If earlier, add hyperlink with full path displayed If Val(Application.Version) > 8 Then 'Using XL2000+ .Hyperlinks.Add _ Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _ Address:=File.Path, _ TextToDisplay:=File.Name Else 'Using XL97 .Hyperlinks.Add _ Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _ Address:=File.Path End If 'Add date last modified, and size in KB With .Range("A65536").End(xlUp) .Offset(0, 1) = File.datelastModified With .Offset(0, 2) .Value = WorksheetFunction.Round(File.Size / 1024, 1) .NumberFormat = "#,##0.0" End With End With 'Add Total From this file to current workbook Set Wb = Workbooks.Open(File) Set Ws = Wb.Sheets("Sheet1") With .Range("A65536").End(xlUp) .Offset(0, 4) = Ws.Range("A1") End With Wb.Close Set Wb = Nothing Set Ws = Nothing End With End If Next File 'Turn back on screen updating Application.ScreenUpdating = True End Sub _ Sub HyperlinkFileList() 'Macro purpose: To create a hyperlinked list of all files in a user 'specified directory, including file size and date last modified 'NOTE: The 'TextToDisplay' property (of the Hyperlink object) was added 'in Excel 2000. This code tests the Excel version and does not use the 'Texttodisplay property if using XL 97. Dim fso As Object, _ ShellApp As Object, _ File As Object, _ SubFolder As Object, _ Directory As Ssortingng, _ Problem As Boolean, _ ExcelVer As Integer, _ TotalD As Ssortingng, _ Wb As Workbook, _ Ws As Worksheet 'Turn off screen flashing Application.ScreenUpdating = False ' Clear sheet Cells.Delete Shift:=xlUp 'Useless : Range("A1").Select 'Create objects to get a listing of all files in the directory Set fso = CreateObject("Scripting.FileSystemObject") 'Prompt user to select a directory Do Problem = False Set ShellApp = CreateObject("Shell.Application"). _ Browseforfolder(0, "Please choose a folder", 0, "D:") 'Browseforfolder(0, "Please choose a folder", 0, "D:\JBOSS\Testdossier") On Error Resume Next 'Evaluate if directory is valid Directory = ShellApp.self.Path Set SubFolder = fso.GetFolder(Directory).Files If Err.Number <> 0 Then If MsgBox("You did not choose a valid directory!" & vbCrLf & _ "Would you like to try again?", vbYesNoCancel, _ "Directory Required") <> vbYes Then Exit Sub Problem = True End If On Error GoTo 0 Loop Until Problem = False 'Set up the headers on the worksheet With ActiveSheet With .Range("A1") .Value = "Listing of all files in:" .ColumnWidth = 40 'If Excel 2000 or greater, add hyperlink with file name 'displayed. If earlier, add hyperlink with full path displayed If Val(Application.Version) > 8 Then 'Using XL2000+ .Parent.Hyperlinks.Add _ Anchor:=.Offset(0, 1), _ Address:=Directory, _ TextToDisplay:=Directory Else 'Using XL97 .Parent.Hyperlinks.Add _ Anchor:=.Offset(0, 1), _ Address:=Directory End If End With With .Range("A2") .Value = "File Name" .Interior.ColorIndex = 15 .ColumnWidth = 50 With .Offset(0, 1) .ColumnWidth = 15 .Value = "Date Modified" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 2) .ColumnWidth = 12 .Value = "File Size (Kb)" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 3) .ColumnWidth = 18 .Value = "Status testdossier" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 4) .ColumnWidth = 22 .Value = "Totaal aantal testgevallen" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 5) .ColumnWidth = 15 .Value = "Uitgevoerd" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 6) .ColumnWidth = 15 .Value = "Akkoord" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 7) .ColumnWidth = 6 .Value = "OK" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With With .Offset(0, 8) .ColumnWidth = 6 .Value = "NOK" .Interior.ColorIndex = 15 .HorizontalAlignment = xlCenter End With End With End With 'Adds each file, details and hyperlinks to the list For Each File In SubFolder If Not Excludes(Right(File.Path, 3)) = True Then With ActiveSheet 'If Excel 2000 or greater, add hyperlink with file name 'displayed. If earlier, add hyperlink with full path displayed If Val(Application.Version) > 8 Then 'Using XL2000+ .Hyperlinks.Add _ Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _ Address:=File.Path, _ TextToDisplay:=File.Name Else 'Using XL97 .Hyperlinks.Add _ Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _ Address:=File.Path End If 'Add date last modified, and size in KB With .Range("A65536").End(xlUp) .Offset(0, 1) = File.datelastModified With .Offset(0, 2) .Value = WorksheetFunction.Round(File.Size / 1024, 1) .NumberFormat = "#,##0.0" End With End With 'Add Total From this file to current workbook Set Wb = Workbooks.Open(File) Set Ws = Wb.Sheets("Sheet1") With .Range("A65536").End(xlUp) .Offset(0, 4) = Ws.Range("A1") End With Wb.Close Set Wb = Nothing Set Ws = Nothing End With End If Next File 'Turn back on screen updating Application.ScreenUpdating = True End Sub