Data uit bestanden tot een bepaalde datum importeren

[jkpieterse]

Dit werkt gewoon bij mij:

Private Sub MT_CopyDataFromWorkbooksIntoMaster()
    Dim lastrow As Long
    Dim lastcolumn As Long
    Dim FolderPath As String
    Dim Filepath As String
    Dim Filename As String

    FolderPath = "H:\Mijn Documenten\Excel\PLANNINGEN - TEST"
    Filepath = FolderPath & "*.xls*"
    Filename = Dir(Filepath)
    Do While Filename <> "" And FileDateTime(FolderPath  & Filename) < DateValue("01-11-2017")
        'Nu iets doen met bestand
        Filename = Dir()
    Loop
End Sub

 

[LJA]

Hallo members,

een mooi en GEZOND 2018 gewenst!

Inmiddels heb ik "mijn uitdaging" weten op te lossen (met hulp van een oud-collega, die o.a. veel van Excel en VBA weet ; ).
Door toepassing van de volgende IF ipv AND heb ik de onderstaande bij mij wel werkende code.

If FileDateTime(FolderPath & Filename) < #11/01/2017# Then
'Andere code
End If

De complete bij mij wel werkende code:

Private Sub MT_CopyDataFromMultipleWorkbooks()

Dim FolderPath As String, Filepath As String, Filename As String

FolderPath = "C:\Mijn Documenten\Excel\PLANNINGENTEST\"
Filepath = FolderPath & "*.xls*"
Filename = Dir(Filepath)

Dim lastrow As Long, lastcolumn As Long

Do While Filename <> ""
   If FileDateTime(FolderPath & Filename) < #11/01/2017# Then
'Meldingen uit
Application.DisplayAlerts = False
'Screen updates uit
Application.ScreenUpdating = False
 
'Werkmap openen
Workbooks.Open (FolderPath & Filename), UpdateLinks:=3, Notify:=False
'Alle Kolommen zichtbaar maken
 ActiveSheet.Cells.EntireColumn.Hidden = False
'Laatste Rij vinden
 lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
 Columns("A:A").Select
 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 Range("A1").FormulaR1C1 = "=R1C4"
 Range("B1").FormulaR1C1 = "=R2C4"
 Range("A1:B1").AutoFill Destination:=Range(Cells(1, 1), Cells(lastrow, 2)), Type:=xlFillDefault
'Laatste Kolom vinden
 lastcolumn = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
'Range(“A6:**”) kopieren en werkmap sluiten
 Range(Cells(6, 1), Cells(lastrow, lastcolumn)).Copy
 ActiveWorkbook.Close

erow = Blad1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

ActiveSheet.Paste Destination:=Worksheets("Blad1").Range(Cells(erow, 1), Cells(erow, lastcolumn))
End If
Filename = Dir

Loop

Heel erg bedankt voor jullie tijd en aandacht!

 

[HSV]

Gelukkig kon je collega de macrorecorder vinden, want echt veel van VBA weet hij niet.
Vertel haar/hem dit maar niet, het zou een teleurstelling kunnen zijn, maar ik wilde dit toch even kwijt.

Als je enig reactie had achter gelaten had je in ieder geval een betere en snellere code hier verkregen (zoals door diverse helpers is aangeboden).

Select, selection zijn overbodig.

Columns.Hidden = False

ipv...

ActiveSheet.Cells.EntireColumn.Hidden = False

Dit ..

Columns("A:A").Select
 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

kan ook zo...

Cells(1).Resize(, 2).EntireColumn.Insert

De paste methode kan direct achter de copy methode met Thisworkbook.sheets("blad1")....

Zo kan ik nog wel doorgaan.

In ieder geval veel plezier ermee.

 

[LJA]

@HSV :
Hallo Harry,

hartelijk dank voor je bericht!
Volgens mij had je beter de voorgaande berichten met meer aandacht kunnen lezen, want je conclusie is "te kort door de bocht".
Mijn oud-collega heeft mij alleen het "IF"-stukje aangeleverd, waarmee ik mijn code bij mij werkend heb gekregen.
(Tot dat moment wisten andere members, waaronder jij, dit voor mij helaas nog niet te realiseren. ; )

Buiten de apart geposte "IF"-code had ik de overige code dus zelf, als VBA-beginneling(!), verzameld / opgesteld.
(Om mogelijk ook andere geïnteresseerden verder te helpen, heb ik de complete, bij mij werkende code gepost.)

Wat fijn dat jij nu de moeite hebt genomen om bepaalde gedeeltes van deze code te verbeteren. Ga zo door! :thumb:
Laten we er samen een positief 2018 van maken, waarbij zoveel mogelijk members verder worden geholpen met werkende stukken codes (ipv negatief geladen commentaar en mededelingen over wat niet werkt. ; )

 

[snb]

Toon je positieve instelling door de baas te stimuleren dit forum financieel te ondersteunen zodat de continuïteit van het forum gewaarborgd blijft.

 

[HSV]

Ik kan wel uitleggen waarom ik geen code heb gerealiseerd.
Als er reacties worden overgeslagen (waaronder de laatst geplaatste van @JKP) ga ik er van uit dat je er niets mee doet.