Power Query naar Excel onvoldoende geheugen

[MollyVH]

Door via een array te werken heb ik die 10 seconden tot 8 kunnen herleiden, van 'aanzienlijk' zou ik maximaal 2,5 seconden durven verwachten

 

[JEC.]

20% sneller op 250000 regels?

 

[MollyVH]

Inderdaad, men zou op beter durven hopen, maar eigenlijk kan ik zelf zowel met 8 als met 10 leven
Alles wat ons nog te doen staat is afwachten hoe het bij TS afloopt...

 

[Georgyboy]

Wauw hoe leuk is dit

@ Jec
jouw code geprobeerd en had vrij snel 28.440 lijnen

@ MollyVH
Met jouw code de eerste keer wat geduld, maar de 2° en 3° keer steeds sneller
Wel bedreigingen uitschakelen
Zie hier nu 43.814 lijnen !

@ Snb
Raar dat het niet wil inladen blijft steeds zoeken zelf na meer dan 1 uur

PS kunnen hier velden worden toegevoegd als: Zie bijlage ?

Alvast bedankt!

 

[Georgyboy]

@ MollyVH

Jouw code werkt als een raket
Was minder dan 20 sec. zelf met bedreigingen éénmaal uitschakelen te selecteren.

Bij deze uitvoering was het 0.06 sec via de code, werkelijk geen 20 sec. via een chronometer.

Kunnen er extra kolommen bij zoals: Name | Extension | Date accessed | Date modified | Date created | Folder Path
Eventueel met een hyperlink naar het bestand

Alvast bedankt!

Kleine aanpassing gedaan

Sub mvh()

Dim startTime As Single 'start timer


Application.ScreenUpdating = False
bestanden = Split(CreateObject("wscript.shell").exec("cmd /c dir c:\users\georges\documents\*.* /a-d /b /s").stdout.readall, vbCrLf)
For i = 0 To UBound(bestanden)
  Cells(i + 1, 1) = bestanden(i)
Next i
MsgBox ("run time: " & Format((Timer - startTime) / 1000000, "#,##0.00") & " seconds") 'end timer
End Sub

 

[JEC.]

Dan wel de timer starten
Als je al die andere info wilt hebben, zal je het via het filesystemobjext moeten doen. Is een simpele uitbreiding van mijn code

 

[MollyVH]

@ Georgyboy,

Zeker kan dat, maar grote kans dat iemand me voor is, want zo meteen de deur uit, en morgen aan een groot project beginnen (je kent dat wel, werkgevers...)
Je vba-chronometer werkt overigens niet op die manier. Zoals je het nu doet zal je een resultaat krijgen dat wordt bepaald door hoe laat het is :d
En timer, dat zijn al seconden, die moet je dus niet gaan delen, en 'starttime' aan het begin van je code moet dan natuurlijk de waarde van timer krijgen.
Ik moet je bovendien al waarschuwen: de verwerkingstijd van je extra vraag zal substantieel meer tijd in beslag nemen

Edit: over snelheid gesproken... weer op snelheid gepakt door JEC

 

[Georgyboy]

Weederom dank!

@ JEC
Betreft "filesystemobjext" weet ik nog niet hoe het in de code moet

Denk iets van deze?

'Create the object of this folder
Set objFolder = FSO.GetFolder(strPath)

'Check if the folder is empty or not
If objFolder.Files.Count = 0 Then
MsgBox "No files were found...", vbExclamation
Exit Sub
End If

'Adding Column names for A, B, and C
Cells(1, "A").Value = "File Name"
Cells(1, "B").Value = "Size"
Cells(1, "C").Value = "Modified Date/Time"

'Find the next available row
NextRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
'Loop through each file in the folder
For Each objFile In objFolder.Files

'List the name, size, and date/time of the current file
Cells(NextRow, 1).Value = objFile.Name
Cells(NextRow, 2).Value = objFile.Size
Cells(NextRow, 3).Value = objFile.DateLastModified

Was zo fier de timer in te voegen die niet correct was maar was blij ondanks het foute resultaat, nu is het leren hoe het echt moet

Bewonder jullie kunnen en blij steeds te mogen leren, ga met heel kleine stapjes vooruit dankzij jullie hulp!

Groeten,
Georgyboy

 

[JEC.]

Zo zou het moeten lukken.
De array "ar" is vergroot zoals je ziet. Dat is afhankelijk van de hoeveelheid kolommen je inlaadt.

Dim oFSO As Object, ar(80000, 3), x As Long

Sub jec()
 Application.ScreenUpdating = False
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 GetFiles "C:\Users\xxx\Downloads"
 If x Then
    Cells(1, 1).Resize(, 5) = Array("Name", "Extension", "DateLastAccessed", "DateLastModified", "DateCreated")
    Cells(2, 2).Resize(x, 4) = ar
 End If
 Erase ar: x = 0
End Sub

Sub GetFiles(xFold)
 Dim Obj As Object
 If Right(xFold, 1) <> "\" Then xFold = xFold & "\"
 With oFSO.GetFolder(xFold)
    For Each Obj In .Files
       ActiveSheet.Hyperlinks.Add Cells(x + 2, 1), Obj, , ,Split(Obj.Name, ".")(0)
       ar(x, 0) = oFSO.GetExtensionName(Obj)
       ar(x, 1) = Obj.DateLastAccessed
       ar(x, 2) = Obj.DateLastModified
       ar(x, 3) = Obj.DateCreated
       x = x + 1
    Next
    For Each Obj In .SubFolders
       GetFiles xFold & Obj.Name
    Next
 End With
End Sub

 

[MollyVH]

@ JEC,

Nieuwsgierig als ik ben even mijn echt werk aan de kant gelegd...
Ziet er over het algemeen goed uit, maar ik vrees wel dat je hyperlinken niet gaan werken.

@ Georgyboy,

Ik heb het me dan maar makkelijk gemaakt door op JEC's aanzet door te gaan, en er ook nog de folder aan toegevoegd.

Dim oFSO As Object, ar(80000, 4), x As Long

Sub mvh()
 Application.ScreenUpdating = False
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 GetFiles "C:\Users\georges\documents"
 If x Then
    Cells(1, 1).Resize(, 6) = Array("Name", "Folder", "Extension", "DateLastAccessed", "DateLastModified", "DateCreated")
    Cells(2, 2).Resize(x, 5) = ar
 End If
 Erase ar: x = 0
End Sub


Sub GetFiles(xFold)
 Dim Obj As Object
 If Right(xFold, 1) <> "\" Then xFold = xFold & "\"
 With oFSO.GetFolder(xFold)
    For Each Obj In .Files
       ActiveSheet.Hyperlinks.Add Cells(x + 2, 1), Obj, , , Obj.Name
       ar(x, 0) = xFold
       ar(x, 1) = oFSO.GetExtensionName(Obj)
       ar(x, 2) = Obj.DateLastAccessed
       ar(x, 3) = Obj.DateLastModified
       ar(x, 4) = Obj.DateCreated
       x = x + 1
    Next
    For Each Obj In .SubFolders
       GetFiles xFold & Obj.Name
    Next
 End With
End Sub

 

[JEC.]

Inderaad thanks, had het niet getest:thumb:

 

[MollyVH]

@ JEC,
Graag gedaan!

@ Georgyboy,
Ik had gisteren niet aandachtig gekeken naar welke eigenschappen je allemaal wou gaan toevoegen. Nu blijkt dat eea qua snelheid nog enorm gaat meevallen.
Als je nog steeds wil gaan timen kan je de main code bv. als volgt aanpassen:

Sub mvh()
 Start = Timer
 Application.ScreenUpdating = False
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 GetFiles "C:\Users\georges\documents"
 If x Then
    Cells(1, 1).Resize(, 6) = Array("Name", "Folder", "Extension", "DateLastAccessed", "DateLastModified", "DateCreated")
    Cells(2, 2).Resize(x, 5) = ar
 End If
 Erase ar: x = 0
 MsgBox Round(Timer - Start, 2) & " sec."
End Sub

 

[Georgyboy]

@ Snb, JEC, MollyVH

Dankjewel :thumb: wat zijn we steeds verwend :d