Inhoud files zichtbaar maken

Status
Niet open voor verdere reacties.
J

Jeannette2509

Gebruiker
Lid geworden
11 nov 2019
Berichten
39
Hallo,

Ik hoop dat iemand mij kan en wil helpen.

Ik heb een macro gevonden waar ik van een zelf te selecteren directory hyperlinks kan maken van alle files. Dit werkt goed.

HTML: 
Listing of all files in:	D:\\	

File Name	  Date Modified	        File Size (Kb)
Test 1.xlsx	  15-7-2020 10:26	12,3
Test 2.xlsx	  15-7-2020 10:27	12,3
Test 3.xlsx	  15-7-2020 10:28	12,3
Test 4.xlsx	  15-7-2020 10:28	12,3
Test 5.xlsx	  15-7-2020 10:29	12,3



Als het mogelijk is zou ik graag deze macro willen uitbreiden, zodat per gevonden file/hyperlink ook de inhoud van de kolommen (rij 2 - kolommen B t/m F - zie voorbeeldje) laten zien, zonder dat de files zichtbaar worden geopend.
Hierdoor kan ik deze dan controleren / aanpassen. Alle files hebben dezelfde lay-out.

Alvast hartelijk bedankt voor het meedenken.


Code: 
Sub HyperlinkFileList()

Dim fso As Object, _
    ShellApp As Object, _
    File As Object, _
    SubFolder As Object, _
    Directory As String, _
    Problem As Boolean, _
    ExcelVer As Integer

Application.ScreenUpdating = False

Set fso = CreateObject("Scripting.FileSystemObject")

Do
    Problem = False
    Set ShellApp = CreateObject("Shell.Application"). _
        Browseforfolder(0, "Please choose a folder", 0, "d:\\")
    
    On Error Resume Next
        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

With ActiveSheet
    With .Range("A1")
        .Value = "Listing of all files in:"
        .ColumnWidth = 40
        If Val(Application.Version) > 8 Then
            .Parent.Hyperlinks.Add _
                Anchor:=.Offset(0, 1), _
                Address:=Directory, _
                TextToDisplay:=Directory
        Else
            .Parent.Hyperlinks.Add _
                Anchor:=.Offset(0, 1), _
                Address:=Directory
        End If
    End With
    With .Range("A2")
        .Value = "File Name"
        .Interior.ColorIndex = 15
        With .Offset(0, 1)
            .ColumnWidth = 15
            .Value = "Date Modified"
            .Interior.ColorIndex = 15
            .HorizontalAlignment = xlCenter
        End With
        With .Offset(0, 2)
            .ColumnWidth = 15
            .Value = "File Size (Kb)"
            .Interior.ColorIndex = 15
            .HorizontalAlignment = xlCenter
        End With
    End With
End With

For Each File In SubFolder
    If Not Excludes(Right(File.path, 3)) = True Then
        With ActiveSheet
            If Val(Application.Version) > 8 Then
            .Hyperlinks.Add _
                Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
                Address:=File.path, _
                TextToDisplay:=File.Name
            Else
            .Hyperlinks.Add _
                Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
                Address:=File.path
            End If
            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
        End With
    End If
Next

End Sub
 

Bijlagen

  • Test 1.xlsx
    12,3 KB · Weergaven: 40
Code: 
Sub M_snb()
   c00 = "D:\"
   c01 = Dir(c00 & "*.xlsx")
   
   Do Until c01 = ""
      c02 = c00 & c01
      With GetObject(c02)
         c03 = c03 & vbCrLf & c01 & "," & FileDateTime(c02) & "," & FileLen(c02) & "," & Join(Application.Index(.Sheets(1).Range("B2:F2").Value, 1, 0), ",")
         .Close 0
      End With
      c01 = Dir
   Loop
   
   If c03 <> "" Then
        CreateObject("scripting.filesystemobject").createtextfile("G:\OF\snb_222.csv").write c03
        Workbook.Open "G:\OF\snb_222.csv"
    End If
End Sub
 
Hallo snb,

Hartelijk bedankt.
Het lukt mij niet om jouw Sub werkend te krijgen.
Moet ik deze aanroepen na de Hyperlink macro?
 
Ik heb deze al jaren gebruikt en verspreid op mijn werk. Haal "eruit" wat je kunt gebruiken.
Heb toen deels de code op internet gevonden en deels zelf gedaan.
Werkte perfect, heb me nooit meer verder in de code verdiept daarna.

Moet nu weer aan het (andere) werk...


PS: jouw bijlage is van een ander projectje van je?
 

Bijlagen

  • Inhoudsopgave.xls
    398 KB · Weergaven: 35
Laatst bewerkt:
Hallo Route99,
Nu zie ik ook de hyperlinks maar moet nu de bestanden een voor een openen om de juiste kolommen er achter te zetten.

Het betreft in werkelijkheid een groot databestand (allen met dezelfde lay-out).

Als ik nu de inhoud van de kolommen (rij 2 - kolommen B t/m F - zie voorbeeldje) naast de links kan zien, kan ik deze snel controleren / aanpassen.
Hiervoor moeten de gevonden hyperlinks dus geopend worden, waarden geplakt naast de link en weer gesloten zonder opslaan.
 
Je moet niets anders gebruiken dan mijn macro.
Vergeet die hyperlinks.
Test de macro per regel met F8.
Pas "G:\OF\snb_222.csv" natuurlijk wel aan.
 
Het zou fijn zijn als dit het uiteindelijke resultaat zou zijn, zodat ik met de link eventueel ook snel kan aanpassen

HTML: 
Listing of all files in:	D:\\							
File Name	   Date Modified	  File Size (Kb)	Naam:	Adres	        PC	        Plaats	      PC/Plaats
Test 1.xlsx	   15-7-2020 10:26	12,3		Smit 1	Teststraat 1	1000 AA	TESTDORP	      1000 AA  TESTDORP
Test 2.xlsx	   15-7-2020 10:27	12,3		Smit 2	Teststraat 2	2000 AA	TESTDORP	      2000 AA  TESTDORP
Test 3.xlsx	   15-7-2020 10:28	12,3		Smit 3	Teststraat 3	3000 AA	TESTDORP	      3000 AA  TESTDORP
Test 4.xlsx	   15-7-2020 10:28	12,3		Smit 4	Teststraat 4	4000 AA	TESTDORP	      4000 AA  TESTDORP
Test 5.xlsx	   15-7-2020 10:29	12,3		Smit 5	Teststraat 5	5000 AA	TESTDORP	      5000 AA  TESTDORP
 
Laatst bewerkt:
Ik heb de macro van snb getest, en an sich doet-ie het prima, alleen opent hij de csv daarna niet. Maar het bestand is wel correct. Dus wellicht moet je eerst eens kijken of het bestand correct wordt aangemaakt. En dat dan openen vanuit de Verkenner.
 
Dan krijg je zo iets:
Code: 
Sub RegelLezen()
   c00 = "C:\Users\OctaF\OneDrive\_HelpMij\jeanette2509\"
   c01 = Dir(c00 & "*.xlsx")
   
   Do Until c01 = ""
      c02 = c00 & c01
      With GetObject(c02)
         c03 = c03 & vbCrLf & c01 & "," & FileDateTime(c02) & "," & FileLen(c02) & "," & Join(Application.Index(.Sheets(1).Range("B2:F2").Value, 1, 0), ",")
         .Close 0
      End With
      c01 = Dir
   Loop
   c03 = "Listing of all files in: " & vbTab & c00 & "\\" & c03
   If c03 <> "" Then
        CreateObject("scripting.filesystemobject").CreateTextFile("C:\Users\OctaF\OneDrive\_HelpMij\jeanette2509\snb_222.csv").Write c03
        Workbook.Open "C:\Users\OctaF\OneDrive\_HelpMij\jeanette2509\snb_222.csv"
    End If
End Sub
 
Verander

Code: 
Workbook.Open "G:\OF\snb_222.csv"

in Workbooks.Open "G:\OF\snb_222.csv"
 
En dáárom gebruik ik altijd IntelliSense :). En moet je dus nooit op anderen vertrouwen :D.
 
Reuze bedankt voor jullie gezamenlijke hulp. Ik ben er al heel blij mee!!

De macro stopt zodra deze in een bestand in een van de kolommen #VERW! tegenkomt.
Is het mogelijk dat deze foutmelding ook wordt weergegeven in lijst en hier niet voor stopt?

Is het mogelijk dat de eerste kolom een hyperlink wordt?
Dan kan ik vanuit het csv-bestand direct naar de file om eventueel aanpassingen te maken of fouten op te lossen.

Alvast bedankt voor de te nemen moeite
 
Laatst bewerkt:
Ik prefereer intelligentie boven intellisense.

Code: 
Sub M_snb()
  On Error Resume Next
  c00 = "G:\"
  c01 = Dir(c00 & "*.xlsx")
   
  Do Until c01 = ""
    c02 = c00 & c01
    With GetObject(c02)
      .Sheets(1).Range("B2:F2").SpecialCells(-4123, 16).ClearContents
      .Sheets(1).Range("B2:F2").SpecialCells(2, 16).ClearContents
         
      c03 = c03 & vbCrLf & "=hyperlink(""" & c02 & """;""" & c01 & """)," & FileDateTime(c02) & "," & FileLen(c02) & "," & Join(Application.Index(.Sheets(1).Range("B2:F2").Value, 1, 0), ",")
      .Close 0
    End With
    c01 = Dir
  Loop
   
  If c03 <> "" Then
    CreateObject("scripting.filesystemobject").createtextfile("G:\OF\snb_222.csv").write c03
    Workbooks.Open("G:\OF\snb_222.csv").Sheets(1).Columns(1).Replace ";", ","
  End If
End Sub
 
Laatst bewerkt:
Hallo snb,

Dit is helemaal FANTASTISCH en werkt SUPER!!

Heel hartelijk bedankt voor je hulp. Ik ben er ontzettend blij mee.

Groet Jeannette
 
En nu nog regel voor regel analyseren ( F8 ) en kijken wat er gebeurt, dan word je weer een hoop wijzer in VBA.
 
snb zei:
Ik prefereer intelligentie boven intellisense.
Klik om te vergroten...
En vergeet dit soort opmerkingen van snb; het getuigt van een hogere intelligentie als je goed gebruik weet te maken van de beschikbare middelen die je hebt, om taken beter uit te voeren. Dolen door de krochten van je eigen hersenen kan namelijk altijd wel :).
 
Alleen werkt die Intellisense soms onvoorspelbaar niet.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan