Option Explicit
Const MijnDir As String = "c:\" 'verander hier het pad waar je files voor je leveranciersbestanden staan
Sub OphalenGegevens()
Dim sPath As String, FileToOpen As Variant, DezeDir As String, HulpMap As Workbook, sFile As String, i As Long, j As Long
Dim sh As Worksheet, Data() As Variant, c As Range, bOpen As Boolean
sPath = MijnDir 'in dit pad staan de leveranciersbestanden
If Right(sPath, 1) <> Application.PathSeparator Then sPath = sPath & Application.PathSeparator 'zet desnoods een "\" achter je pad
DezeDir = CurDir 'onthoud huidige directory
ChDir sPath 'ga naar leveranciersdirectory
FileToOpen = Application.GetOpenFilename("Leveranciersbestanden (*.xls*), *.xls*") 'open venster om file te kiezen en laat ze kiezen
FileToOpen = Replace(FileToOpen, "~$", "") 'in open files staat dit teken soms
ChDir DezeDir 'keer terug naar oorspronkelijke map
If FileToOpen = False Then 'kijk wat er geselecteerd is, indien niets (=annuleren)
MsgBox "je hebt niets gekozen, einde verhaal" 'einde verhaal
Exit Sub
Else
On Error Resume Next 'doorgaan bij fouten
sFile = Mid(FileToOpen, InStrRev(FileToOpen, "\") + 1, 255) 'deel na het laatste "\"-teken in die tekst
Set HulpMap = Nothing 'hulpje resetten
Set HulpMap = Workbooks(sFile) 'kijk of geselecteerde map al niet open staan
bOpen = (Not HulpMap Is Nothing)
If Not bOpen Then 'is hulpje niets, dan is die map niet open
Workbooks.Open FileToOpen 'open ze dan
Set HulpMap = Workbooks(sFile) 'kijk of geselecteerde map al niet open staan
If HulpMap Is Nothing Then MsgBox " ik krijg die map niet open": Exit Sub 'hulpje nog altijd niets, dan heb je een probleem = stoppen
End If
Application.ScreenUpdating = False
With HulpMap 'met die map
For Each sh In .Sheets 'loop 1 voor 1 alle werkbladen af
With sh 'in dat werkblad
i = WorksheetFunction.Max(.Range("A" & Rows.Count).End(xlUp).Row, .Range("B" & Rows.Count).End(xlUp).Row, .Range("C" & Rows.Count).End(xlUp).Row, .Range("D" & Rows.Count).End(xlUp).Row, .Range("E" & Rows.Count).End(xlUp).Row) 'laatst gevulde rij voor A tot E
If i > 3 Then 'laatste rij groter dan 3
ReDim Data(i - 4, 5) 'maak een array klaar kwa omvang
For j = 0 To UBound(Data) 'rij per rij invoeren
Data(j, 0) = IIf(.Range("C1").Value = "", "???", .Range("C1").Value) '1e element = datum, indien niet gekend "???"
Data(j, 1) = sh.Name 'leveranciersnaam
Data(j, 2) = .Cells(j + 4, "A").Value 'machine
Data(j, 3) = .Cells(j + 4, "E").Value 'werknemer
Next
End If
Set c = ThisWorkbook.Sheets("Hoofdbestand").Range("D" & Rows.Count).End(xlUp).Offset(1) 'eerstvolgende lege cel in de D-kolom van "hoofdbestand"
If c.Row > 6 Then '6 is de 1e rij met gegevens in "hoofdbestand"
c.Offset(-1).EntireRow.Copy 'kopieer de ganse rij ervoor
With c.Resize(UBound(Data) + 1).EntireRow 'naar alle straks in te vullen rijen
.PasteSpecial xlPasteFormulas 'plak de formules
.PasteSpecial xlPasteValidation ' en de validaties
.SpecialCells(xlConstants).ClearContents 'maak cellen met tekst leeg
.SpecialCells(xlNumbers).ClearContents 'maak cellen met tekst leeg
End With
c.Resize(UBound(Data) + 1, UBound(Data, 2) + 1).Value = Data 'schrijf daar alle gegevens
End If
End With
Next
End With
If Not bOpen Then HulpMap.Close False 'als de map niet open was, dan sluit je hem zonder opslaan
End If
With Application
.CutCopyMode = False
.Goto ThisWorkbook.Sheets("Hoofdbestand").Range("D" & Rows.Count).End(xlUp).Offset(1) 'eerstvolgende lege cel in de D-kolom van "hoofdbestand"
.ScreenUpdating = True
End With
End Sub
