Loop vraag voor importeren op basis van datum in filename

[Rubenio]

Bezig met een voor mij wat ingewikkelder projectje.
Probeer een Excel file aan te maken die automatisch een paar standaard gegevens haalt uit een groot aantal bestanden die in dezelfde map zijn opgeslagen. Deze bestanden hebben als kenmerk dat de datum in de bestandsnaam is opgenomen.

bestand "import" : hier wil ik alle gegevens in verzamelen
bestand "14-6-2016": is een voorbeeldbestand, het gaat altijd om de range B1:B4

De 2 vragen die ik heb zijn:

- hoe zorg ik ervoor dat deze macro start zodra het "import" bestand wordt geopend?

De loop die ik in gedachte had was zoiets als:
1. zoek/selecteer in "import" bestand in rij 2 naar de eerste datum waar nog geen waarde onder staat.
2. open de file die overeen komt met deze datum en selecteer & kopieer de range B1:B4 (in geval van 14-6-2016 naar B3:B6)
3. plak selectie in "import" bestand en sluit bestand waar data vandaan kwam
4. zoek eerstvolgende datum zonder waarder daaronder - totdat er geen bestand meer wordt gevonden

- hoe moet deze loop eruit zien?

 

[Gijsbert1]

Het zal vast wel makkelijker kunnen, maar: Zet de volgende Macro in bestand "Import":

Pas het rood gemarkeerde stukje aan naar de bestandslocatie waarin de "datum" bestanden te vinden zijn!

Sub gijs()

Dim TheDate As Date
Dim FileName As String
Dim DirFile As String
Range("A2").Select
Vullen:
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value = "" Then GoTo Stoppen
TheDate = ActiveCell.Value
FileName = TheDate & ".xlsx"
DirFile = "[COLOR="#FF0000"][B]C:\Helpmij\[/B][/COLOR]" & FileName
If Dir(FileName) = "" Then
GoTo Vullen
Else
ActiveCell.Offset(1, 0).FormulaR1C1 = "='[" & FileName & "]Blad1'!R[-2]C2"
ActiveCell.Offset(1, 0).AutoFill Destination:=Range _
(ActiveCell.Offset(1, 0).Address & ":" & ActiveCell.Offset(4, 0).Address), Type:=xlFillDefault
End If
GoTo Vullen
Stoppen:
Rows("6:6").Style = "Percent"

End Sub

 

[Rubenio]

Dank voor de input Gijs, ziet er zeer bruikbaar uit.
Ga ermee aan de slag

 

[Rubenio]

@Gijsbert

Nog even een vraagje:
Ik kreeg ' pas werkend toen ik If Dir(FileName) = "" Then had gewijzigd naar If DirFile = """ Then
Hij haalt nu prima de waarde uit de bestanden maar loopt alleen vast zodra hij bij een datum komt waar nog geen bestand van aanwezig is. Dan opent automatisch een soort verkenner. Is dat nog weg te krijgen?

 

[Rubenio]

O wacht, ben er al uit - ik moet er gewoon voor zorgen dat die datum gewoon niet in de rij staat

 

[Gijsbert1]

Ik kreeg ' pas werkend toen ik If Dir(FileName) = "" Then had gewijzigd naar If DirFile = """ Then
Hij haalt nu prima de waarde uit de bestanden maar loopt alleen vast zodra hij bij een datum komt waar nog geen bestand van aanwezig is. Dan opent automatisch een soort verkenner. Is dat nog weg te krijgen?

Met if dir(FileName) wordt juist gekeken of het bestand met de data aanwezig is... en zo niet slaat excel hem over en gaat de code gewoon door met de data die erna komt! Dit had je niet moeten aanpassen!
Je moet de regel die ervoor staat uiteraard wel aanpassen. (rood gemarkeerd in mijn vorige voorbeeld!) Misschien dat je daar een tikfout hebt gemaakt?

Je kunt ook de volgende code proberen:
voorwaarde is hier wel dat het import bestand in dezelfde map staat opgeslagen als de data bestanden

Dim TheDate As Date
Dim FileName As String
Dim DirFile As String
Range("A2").Select
Vullen:
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value = "" Then GoTo Stoppen
TheDate = ActiveCell.Value
FileName = TheDate & ".xlsx"
[COLOR="#0000FF"]DirFile = Application.ActiveWorkbook.Path & FileName[/COLOR]
If Dir(FileName) = "" Then
GoTo Vullen
Else
ActiveCell.Offset(1, 0).FormulaR1C1 = "='[" & FileName & "]Blad1'!R[-2]C2"
ActiveCell.Offset(1, 0).AutoFill Destination:=Range _
(ActiveCell.Offset(1, 0).Address & ":" & ActiveCell.Offset(4, 0).Address), Type:=xlFillDefault
End If
GoTo Vullen
Stoppen:
Rows("6:6").Style = "Percent"

De aanpassing van de code is de blauwe regel

Succes ermee.. :thumb:

 

[VenA]

Al je wilt dat een macro start bij het openen van een bestand dan moet je deze onder Thisworkbook zetten of van daaruit aanroepen. Dit gaat met het Workbook_Open() event.

Als ik de vraag goed begrepen heb kom ik tot zoiets.

Sub VenA()
Dim ar, cl, c00
Application.ScreenUpdating = False
For Each cl In Rows(2).SpecialCells(2, 1)
    If cl.Offset(1) = "" Then
        c00 = ThisWorkbook.Path & "\" & Format(cl, "d-m-yyyy") & ".xlsx"
        ReDim ar(3)
        If Dir(c00) <> "" Then
            Workbooks.Open c00
            With Workbooks(Format(cl, "d-m-yyyy") & ".xlsx")
                ar = .Sheets(1).[B1:B4]
                .Close 0
            End With
            cl.Offset(1).Resize(4, 1) = ar
        End If
    End If
Next cl
End Sub

Private Sub Workbook_Open()
VenA
End Sub

 

[HSV]

Iets anders geschreven.

Sub hsv()
Dim cl As Range, c00 As String
Application.ScreenUpdating = False
For Each cl In Rows(2).SpecialCells(2).Offset(,1).SpecialCells(2)
if cl.offset(1) = "" then   
c00 = ThisWorkbook.Path & "\" & cl & ".xlsx"
    If Dir(c00) <> "" Then
       With Workbooks.Open(c00)
          cl.offset(1).Resize(4) = .Sheets(1).[B1:B4].Value
         .Close 0
       End With
   End If
end if
Next cl
End Sub

Of.

Sub hsv()
Dim cl As Range, c00 As String
Application.ScreenUpdating = False
on error resume next
For Each cl In Rows(2).SpecialCells(2).Offset(1).SpecialCells(4) 
c00 = ThisWorkbook.Path & "\" & cl.offset(-1) & ".xlsx"
    If Dir(c00) <> "" Then
       With Workbooks.Open(c00)
          cl.Resize(4) = .Sheets(1).[B1:B4].Value
         .Close 0
       End With
   End If
Next cl
End Sub

 

[VenA]

Is weer een mooi stukje compacter. :thumb:

 

[Rubenio]

Was er al aardig mee aan het klooien :d Iedereen dank voor de input! Ga er weer mee verder.