Sub VulGegevensLPKIn(control As IRibbonControl)
Application.ScreenUpdating = False
mySheetName = ActiveSheet.Name
With Range("A1000").End(xlUp).Offset(2, 0)
.Resize(, 2).ClearContents
str = InputBox("Loopkraan ingeven", "Loopkraan:")
If Not str = "" Then
.value = str
Else
MsgBox "je bent gestopt"
Exit Sub
End If
i = Application.Match(str, Blad10.Columns(3), 0)
Sheets("Systeem").Range("LK_Row_nummer") = i
If Not IsError(i) Then
.Offset(, 1) = Blad10.Cells(i, 4).value
Else
MsgBox "De ingevulde loopkraan """ & str & """ is niet terug gevonden."
.ClearContents
Exit Sub
End If
.Font.Bold = True
.Font.Size = 14
.Font.Underline = True
.EntireRow.AutoFit
End With
Sheets("Systeem").Range("IBNStart").value = Sheets(mySheetName).Range("A1000").End(xlUp).row + 2 '45
Sheets("Systeem").Range("IBNEinde").value = Sheets("Systeem").Range("IBNStart") + 13 '58
iRowStart = Sheets("Systeem").Range("IBNStart")
iRowEinde = Sheets("Systeem").Range("IBNEinde")
Sheets("Systeem").Select
Range("IBN").Select
Selection.Copy
Sheets(mySheetName).Select
Range("A" & iRowStart).Select
ActiveSheet.Paste
Rows(iRowStart + 1 & ":" & iRowEinde).Select
Selection.Rows.Group
Sheets("Systeem").Range("CHStart").value = Sheets("Systeem").Range("IBNEinde") + 2 '60
iRowStart = Sheets("Systeem").Range("CHStart")
Sheets("Systeem").Select
Range("ColumnHeader").Select
Selection.Copy
Sheets(mySheetName).Select
Range("A" & iRowStart).Select
ActiveSheet.Paste
invoeren_gegevens_LPK
vervolg
End Sub
Sub invoeren_gegevens_LPK()
Dim arr, arr2, sn, i As Long, ii As Long, j As Long, x As Long, n As Long, c As Range, c00, c01, c02, twb As Worksheet
Dim lDatum As Date
Dim str As String
Application.ScreenUpdating = False
str = Sheets("Systeem").Range("LK_Row_nummer")
Workbooks.Open ThisWorkbook.path & "\Output Danny.xlsx"
'With GetObject(ThisWorkbook.path & "\Output Danny.xlsx")
With ActiveWorkbook
Set twb = ThisWorkbook.ActiveSheet
arr = Split(twb.Name, "_")
With Workbooks("Output Danny.xlsx").Sheets("Rawdata")
With .Cells(1).CurrentRegion
For x = 0 To 1
If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
lDatum = DateValue(DateSerial(Split(twb.[c1], "/")(2), Split(twb.[c1], "/")(1), Split(twb.[c1], "/")(0)))
.AutoFilter Field:=1, Criteria1:=">=" & lDatum, Operator:=xlAnd, Criteria2:="<" & lDatum + 1
' .AutoFilter 1, CDate(Format(ThisWorkbook.Sheets(i).Cells(1, 3).value, "dd/mm/yyyy"))'deze code werkt op het werk
' .AutoFilter 1, CDate(Format(twb.Cells(1, 3).value, "dd/mm/yyyy"))'deze code werkt op het werk
.AutoFilter 5, arr(0), 2, arr(1)
.AutoFilter 6, Blad10.Cells(str, 4) & "*"
sn = .Cells(1).CurrentRegion
ReDim arr2(1 To UBound(sn), 1 To UBound(sn, 2))
For ii = 2 To UBound(sn)
If Not .Rows(ii).Hidden Then
n = n + 1
For j = 1 To UBound(sn, 2)
arr2(n, 1) = sn(ii, 3)
arr2(n, 2) = sn(ii, 9)
arr2(n, 3) = sn(ii, 10)
arr2(n, 8) = sn(ii, 5)
arr2(n, 9) = sn(ii, 13)
c00 = Application.index(sn, 1, 0)
c01 = Replace(Format(twb.Cells(1, 3), "dd-mm-yyyy"), "-", ".")
c02 = Application.Match(c01, c00, 0)
If Not IsError(c02) Then arr2(n, 10) = sn(ii, c02)
arr2(n, 11) = sn(ii, 2)
arr2(n, 13) = sn(ii, 8)
arr2(n, 15) = IIf(arr2(n, 8) = "RE-1", ThisWorkbook.Sheets("systeem").Cells(1, 1).value, ThisWorkbook.Sheets("systeem").Cells(2, 1).value)
Next j
End If
Next ii
'twb.Range("A" & iRowStart + 1).Resize(n, 15) = arr2
twb.Range("A1000").End(xlUp).Offset(1).Resize(n, 15) = arr2
n = 0
Erase arr2
Next x
End With
End With
.Close 0
End With
End Sub
Sub vervolg()
Sheets("Systeem").Range("CHEinde").value = Sheets(mySheetName).Range("A1000").End(xlUp).row '62
iRowEinde = Sheets("Systeem").Range("CHEinde") + 2
Rows(iRowStart + 1 & ":" & iRowEinde).Select '61 & 62
Selection.Rows.Group
Sheets("Systeem").Range("CHBTRStart").value = Sheets("Systeem").Range("CHEinde") + 2 '66
iRowStart = Sheets("Systeem").Range("CHBTRStart")
Sheets("Systeem").Select
Range("ColumnHeaderBTR").Select
Selection.Copy
Sheets(mySheetName).Select
Range("A" & iRowStart).Select
ActiveSheet.Paste
'Hieronder vult men weer gegevens in via volgend bestandje op tabblad 2, locatie is:
'ChDir "\\Sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Betacel\Projecten"
'Workbooks.Open Filename:="file:\\Sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Betacel\Projecten\planningEXT.xlsx", ReadOnly:=True
'Eerst kijkt men naar de datum, dan naar LKXXX en men schrijft de gegevens weg op de juiste plaats.
'Indien er geen gegevens aanwezig zijn dan melding: "Geen gegevens aanwezig voor Betrouwbaarheidscel" en code verder laten lopen
Sheets("Systeem").Range("CHBTREinde").value = Sheets(mySheetName).Range("A1000").End(xlUp).row + 2 '68
iRowEinde = Sheets("Systeem").Range("CHBTREinde")
Rows(iRowStart + 1 & ":" & iRowEinde).Select '67 & 68
Selection.Rows.Group
Sheets("Systeem").Range("CHBGEStart").value = Sheets("Systeem").Range("CHBTREinde") + 2 '70
iRowStart = Sheets("Systeem").Range("CHBGEStart")
Sheets("Systeem").Select
Range("ColumnHeaderBGE").Select
Selection.Copy
Sheets(mySheetName).Select
Range("A" & iRowStart).Select
ActiveSheet.Paste
'Hieronder vult men weer gegevens in via volgend bestandje op tabblad 2, locatie is:
'ChDir "\\Sidmar.be\dfs\ORGANISATIE\LAD\GROEP\LPK\Planning\Systeem"
'Workbooks.Open Filename:="file:\\sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Planning\Systeem\Externen.xlsx", ReadOnly:=True
'Eerst kijkt men naar de datum, dan naar LKXXX en men schrijft de gegevens weg op de juiste plaats.
'Indien er geen gegevens aanwezig zijn dan melding dat er "geen gegevens aanwezig voor Externen"en code verder laten lopen
Sheets("Systeem").Range("CHBGEEinde").value = Sheets(mySheetName).Range("A1000").End(xlUp).row + 2 '70
iRowEinde = Sheets("Systeem").Range("CHBGEEinde")
Rows(iRowStart + 1 & ":" & iRowEinde).Select '71 & 72
Selection.Rows.Group
Range("A" & iRowStart + 4).Select
Application.ScreenUpdating = True
End Sub
