How do you split a VBA code that is too long? Below I show a snippet of the code. It takes up a lot of space because it has to repeat what is below, which is Dock III, for the other docks and now I wanted to add a bedding, but then the procedure became too long. But I have tried putting the bedding in as another Sub, but it dosen't excecute the VBA in external Sub. Think it might be somting about the counter.
There may be some Danish in the code/notes 😁 Anyone that can help me in right direction?
Sub Booking()
Application.ScreenUpdating = False
Call Lav_Kalender_Ny 'Get the macro that creates the calendar
Dim ws3 As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws4 As Worksheet
Dim PeriodeStart As Date, PeriodeSlut As Date, AnkomstVaerft As Date, AfgangVaerft As Date, AnkomstDok As Date, AbgangDok As Date
Dim ProjectCount As Integer, Counter As Integer, Periode As Integer, PeriodeSkip As Integer, StartAnkomst As Integer, PeriodeDokSlut As Integer, RowCount As Long, PeriodeDok As Integer, ColumnCount As Integer, LineCount As Integer
Dim Doc As String, WeekDay As String, laydaysDok3 As Integer, CounterStatistikDok As Integer
Dim VDate As Boolean
Set ws1 = Sheets("Indtastningsark")
Set ws3 = Sheets("Vis_Oversigt")
Set ws2 = Sheets("Statistik")
Set ws4 = Sheets("MIS")
VDate = IsDate(Range("C4"))
If VDate = False Then
Exit Sub
End If
VDate = IsDate(Range("E4"))
If VDate = False Then
Exit Sub
End If
If ws3.Cells(4, 6) > 400 Then
Exit Sub
End If
If ws3.Cells(4, 6) < 0 Then
Exit Sub
End If
ActiveSheet.Unprotect Password:="5980"
PeriodStart = ws3.Cells(4, 3).Value 'PeriodeStart is the start date for the calendar (entered on Vis_Oversigt)
PeriodEnd = ws3.Cells(4, 5).Value 'PeriodeEnd is the end date for the calendar (entered on Vis_Oversigt)
Period = ws3.Cells(4, 6) 'The period is the number of days that the calendar runs
Counter = 7 ' Counter is set to 7, as the projects must be entered starting from row 7 on Vis_Oversigt
ProjectCount = ws1.Range("B" & Rows.Count).End(xlUp).Row 'Finds the number of entered projects on the sheet Input sheet
RowCount = ws3.Range("B" & Rows.Count).End(xlUp).Row 'Finds the number of entered rows on the sheet Vis_Oversigt
ws3.Range(Cells(6, 1), Cells(RowCount, 9)).UnMerge
ws3.Range(Cells(6, 1), Cells(RowCount, 9)).Clear 'Deletes retrieved projects on the sheet Vis_Oversigt
ws3.Range(Cells(3, 1), Cells(RowCount + 6, 1)).RowHeight = 18
ws3.Columns("A:A").NumberFormat = "@"
ws4.Activate
Range(Cells(1, 1), Cells(5, 500)).Clear
ws3.Activate
laydaysDok3 = 0
from Sheet Input sheet. Sorted by DOK/KAJ
For j = 3 To ProjectCount
AnkomstVaerft = ws1.Cells(j, 5).Value 'Time project arrives at shipyard
AbgangVaerft = ws1.Cells(j, 6).Value 'Time ship departs from shipyard
Dock = ws1.Cells(j, 7).Value 'Project's dock number or along quay
AnkomstDok = ws1.Cells(j, 8).Value 'Time project goes into dock (if it does this)
AbgangDok = ws1.Cells(j, 9).Value 'Time project leaves dock (if it does this)
CounterStatistikDok = 0
If (ArrivalDock >= PeriodStart And ArrivalDock <= PeriodEnd And Dock = "DOC III") Then 'Checks if arrival is within the period and that the ship must be in DOC xxx
ws3.Range(Cells(Counter - 1, 1), Cells(Counter + 1, 1)).Merge
ws3.Range(Cells(Counter - 1, 2), Cells(Counter + 1, 2)).Merge
ws3.Range(Cells(Counter - 1, 3), Cells(Counter + 1, 3)).Merge
ws3.Range(Cells(Counter - 1, 4), Cells(Counter + 1, 4)).Merge
ws3.Range(Cells(Counter - 1, 5), Cells(Counter + 1, 5)).Merge
ws3.Range(Cells(Counter - 1, 6), Cells(Counter + 1, 6)).Merge
ws3.Range(Cells(Counter - 1, 7), Cells(Counter + 1, 7)).Merge
ws3.Range(Cells(Counter - 1, 8), Cells(Counter + 1, 8)).Merge
ws3.Cells(Counter - 1, 1).Value = ws1.Cells(j, 1).Value 'Transfers values from sheet Input sheet to Sheet Vis_Oversigt
ws3.Cells(Counter - 1, 2).Value = ws1.Cells(j, 2).Value
ws3.Cells(Counter - 1, 3).Value = ws1.Cells(j, 3).Value
ws3.Cells(Counter - 1, 4).Value = ws1.Cells(j, 4).Value
ws3.Cells(Counter - 1, 5).Value = ws1.Cells(j, 7).Value
ws3.Cells(Counter - 1, 7).Value = ws1.Cells(j, 5).Value
ws3.Cells(Counter - 1, 8).Value = ws1.Cells(j, 6).Value
If PeriodEnd < DepartureYard Then 'Checks if the ship departs the yard after the calendar end date (this is done to avoid marking outside the calendar area)
PeriodShip = Period 'PeriodShip is defined to be the same time period as the calendar (just to avoid marking outside the calendar area)
Else
PeriodShip = ws1.Cells(j, 6) - PeriodStart 'If the ship departs the yard before the calendar ends, PeriodShip is defined to be from the start date of the calendar to the ship departure
End If
ws3.Range(Cells(Counter, ((ArrivalYard - PeriodStart) + 10)), Cells(Counter, PeriodShip + 10)).Interior.ColorIndex = 5 'Colors the range blue in calendar
If ArrivalDoc <> "00:00:00" And DepartureDoc <> "00:00:00" Then 'Checks if the ship is scheduled to dock
If ArrivalDoc >= PeriodStart And ArrivalDoc <= PeriodEnd Then 'Checks if the arrival is within the calendar period
If PeriodEnd <= DepartureDoc Then 'Checks if the docking period runs the entire calendar period
PeriodEndDoc = Period
ElseIf PeriodEnd >= DepartureDoc Then 'Checks if the docking period expires before the calendar period
PeriodEndDoc = ws1.Cells(j, 9) - PeriodStart
End If
ws3.Range(Cells(Counter, ((ArrivalDoc - PeriodStart) + 10)), Cells(Counter, PeriodEndDoc + 10)).Interior.ColorIndex = 3
ws4.Activate
Range(Cells(1, ((ArrivalDoc - PeriodStart) + 1)), Cells(1, PeriodDokEnd + 1)).Value = 1
ws3.Activate
'CounterStatisticDok = PeriodDokEnd - (ArrivalDok - PeriodStart) 'TY
Than If
Than If
Counter = Counter + 3 'advances counter and skips line
ElseIf PeriodStart > Arrival Yard And PeriodEnd < Departure Yard And Dock = "DOK III" Then
ws3.Range(Cells(Counter - 1, 1), Cells(Counter + 1, 1)).Merge
ws3.Range(Cells(Counter - 1, 2), Cells(Counter + 1, 2)).Merge
ws3.Range(Cells(Counter - 1, 3), Cells(Counter + 1, 3)).Merge
ws3.Range(Cells(Counter - 1, 4), Cells(Counter + 1, 4)).Merge
ws3.Range(Cells(Counter - 1, 5), Cells(Counter + 1, 5)).Merge
ws3.Range(Cells(Counter - 1, 6), Cells(Counter + 1, 6)).Merge
ws3.Range(Cells(Counter - 1, 7), Cells(Counter + 1, 7)).Merge
ws3.Range(Cells(Counter - 1, 8), Cells(Counter + 1, 8)).Merge
ws3.Cells(Counter - 1, 1).Value = ws1.Cells(j, 1).Value 'Transfers values from sheet Input sheet to Sheet Vis_Oversigt
ws3.Cells(Counter - 1, 2).Value = ws1.Cells(j, 2).Value
ws3.Cells(Counter - 1, 3).Value = ws1.Cells(j, 3).Value
ws3.Cells(Counter - 1, 4).Value = ws1.Cells(j, 4).Value
ws3.Cells(Counter - 1, 5).Value = ws1.Cells(j, 7).Value
ws3.Cells(Counter - 1, 7).Value = ws1.Cells(j, 5).Value
ws3.Cells(Counter - 1, 8).Value = ws1.Cells(j, 6).Value
Range(Cells(Counter, 10), Cells(Counter, Period + 10)).Interior.ColorIndex = 5
If AnkomstDok <> "00:00:00" And AfgangDok <> "00:00:00" Then
If PeriodeStart >= AnkomstDok And PeriodeSlut <= AfgangDok Then
Range(Cells(Counter, 10), Cells(Counter, Periode + 10)).Interior.ColorIndex = 3
ws4.Activate
Range(Cells(1, 1), Cells(1, Periode + 1)).Value = 1
ws3.Activate
'CounterStatistikDok = Periode
End If
If AnkomstDok >= PeriodeStart And AnkomstDok <= PeriodeSlut Then
If PeriodeSlut <= AfgangDok Then
PeriodeDokSlut = Periode
ElseIf PeriodeSlut > AfgangDok Then
PeriodeDokSlut = ws1.Cells(j, 9) - PeriodeStart
End If
ws3.Range(Cells(Counter, ((AnkomstDok - PeriodeStart) + 10)), Cells(Counter, PeriodeDokSlut + 10)).Interior.ColorIndex = 3
ws4.Activate
ws4.Range(Cells(1, ((AnkomstDok - PeriodeStart) + 1)), Cells(1, PeriodeDokSlut + 1)).Value = 1
ws3.Activate
'CounterStatistikDok = (AnkomstDok - PeriodeStart) - PeriodeDokSlut
End If
If AnkomstDok < PeriodeStart And AfgangDok <= PeriodeSlut Then
Range(Cells(Counter, 10), Cells(Counter, (AfgangDok - PeriodeStart) + 10)).Interior.ColorIndex = 3
ws4.Activate
Range(Cells(1, 1), Cells(1, (AfgangDok - PeriodeStart) + 1)).Value = 1
ws3.Activate
'CounterStatistikDok = (AfgangDok - PeriodeStart)
End If
End If
Counter = Counter + 3
ElseIf AfgangVaerft >= PeriodeStart And AfgangVaerft <= PeriodeSlut And AnkomstVaerft < PeriodeStart And Dok = "DOK III" Then
ws3.Range(Cells(Counter - 1, 1), Cells(Counter + 1, 1)).Merge
ws3.Range(Cells(Counter - 1, 2), Cells(Counter + 1, 2)).Merge
ws3.Range(Cells(Counter - 1, 3), Cells(Counter + 1, 3)).Merge
ws3.Range(Cells(Counter - 1, 4), Cells(Counter + 1, 4)).Merge
ws3.Range(Cells(Counter - 1, 5), Cells(Counter + 1, 5)).Merge
ws3.Range(Cells(Counter - 1, 6), Cells(Counter + 1, 6)).Merge
ws3.Range(Cells(Counter - 1, 7), Cells(Counter + 1, 7)).Merge
ws3.Range(Cells(Counter - 1, 8), Cells(Counter + 1, 8)).Merge
ws3.Cells(Counter - 1, 1).Value = ws1.Cells(j, 1).Value 'Overfører værdier fra sheet Indtastningsark til Sheet Vis_Oversigt
ws3.Cells(Counter - 1, 2).Value = ws1.Cells(j, 2).Value
ws3.Cells(Counter - 1, 3).Value = ws1.Cells(j, 3).Value
ws3.Cells(Counter - 1, 4).Value = ws1.Cells(j, 4).Value
ws3.Cells(Counter - 1, 5).Value = ws1.Cells(j, 7).Value
ws3.Cells(Counter - 1, 7).Value = ws1.Cells(j, 5).Value
ws3.Cells(Counter - 1, 8).Value = ws1.Cells(j, 6).Value
Range(Cells(Counter, 10), Cells(Counter, (AfgangVaerft - PeriodeStart) + 10)).Interior.ColorIndex = 5
If AnkomstDok <> "00:00:00" And AfgangDok <> "00:00:00" Then 'Tjekker om skibet er sat til at skulle i dok
If PeriodeStart >= AnkomstDok And AfgangDok >= PeriodeStart Then 'Tjekker om kalenderperioden optræder i værftsperioden
Range(Cells(Counter, 10), Cells(Counter, ((AfgangDok - PeriodeStart) + 10))).Interior.ColorIndex = 3
ws4.Activate
Range(Cells(1, 1), Cells(1, ((AfgangDok - PeriodeStart) + 1))).Value = 1
ws3.Activate
'CounterStatistikDok = (AfgangDok - PeriodeStart)
End If
If AnkomstDok >= PeriodeStart Then 'Tjekker om ankomsten ligger inden for kalenderperioden
ws3.Range(Cells(Counter, ((AnkomstDok - PeriodeStart) + 10)), Cells(Counter, (AfgangDok - PeriodeStart) + 10)).Interior.ColorIndex = 3
ws4.Activate
Range(Cells(1, ((AnkomstDok - PeriodeStart) + 1)), Cells(1, (AfgangDok - PeriodeStart) + 1)).Value = 1
ws3.Activate
'CounterStatistikDok = (AfgangDok - PeriodeStart) - (AnkomstDok - PeriodeStart)
End If
If AnkomstDok <= PeriodeStart And AfgangDok > PeriodeStart Then
Range(Cells(Counter, 10), Cells(Counter, (AfgangDok - PeriodeStart) + 10)).Interior.ColorIndex = 3
ws4.Activate
Range(Cells(1, 1), Cells(1, (AfgangDok - PeriodeStart) + 1)).Value = 1
ws3.Activate
'CounterStatistikDok = (AfgangDok - PeriodeStart)
End If
End If
Counter = Counter + 3
End If
'If CounterStatistikDok > 0 Then
CounterStatistikDok = CounterStatistikDok + 1
'End If
'laydaysDok3 = laydaysDok3 + CounterStatistikDok
'ws2.Cells(5, 2).Value = laydaysDok3
'ws2.Cells(5, 2).Value = Excel.WorksheetFunction.Sum(ws4.Range("A1:A500"))
Next j
Call Bedding
And below almost the same as above, for the next docks.
I have tried making Sub for Bedding with and without what is above the line with the text: 'Here follows the algorithm for Bedding
Sub for bedding:
Sub Bedding()
Application.ScreenUpdating = False
Call Lav_Kalender_Ny 'Get the macro that creates the calendar
Dim ws3 As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws4 As Worksheet
Dim PeriodeStart As Date, PeriodeSlut As Date, AnkomstVaerft As Date, AfgangVaerft As Date, AnkomstDok As Date, AfgangDok As Date
Dim ProjectCount As Integer, Counter As Integer, Periode As Integer, PeriodeSkib As Integer, StartAnkomst As Integer, PeriodeDokSlut As Integer, RowCount As Long, PeriodeDok As Integer, ColumnCount As Integer, LineCount As Integer
Dim Dok As String, WeekDay As String, laydaysDok3 As Integer, CounterStatistikDok As Integer
Dim VDate As Boolean
Set ws1 = Sheets("Indtastningsark")
Set ws3 = Sheets("Vis_Oversigt")
Set ws2 = Sheets("Statistik")
Set ws4 = Sheets("MIS")
VDate = IsDate(Range("C4"))
If VDate = False Then
Exit Sub
End If
VDate = IsDate(Range("E4"))
If VDate = False Then
Exit Sub
End If
If ws3.Cells(4, 6) > 400 Then
Exit Sub
End If
If ws3.Cells(4, 6) < 0 Then
Exit Sub
End If
'Her følger algortimen for Bedding
For j = 3 To ProjectCount
AnkomstVaerft = ws1.Cells(j, 5).Value
AfgangVaerft = ws1.Cells(j, 6).Value
Dok = ws1.Cells(j, 7).Value
AnkomstDok = ws1.Cells(j, 8).Value '
AfgangDok = ws1.Cells(j, 9).Value
If (AnkomstVaerft >= PeriodeStart And AnkomstVaerft <= PeriodeSlut And Dok = "Bedding") Then
ws3.Range(Cells(Counter - 1, 1), Cells(Counter + 1, 1)).Merge
ws3.Range(Cells(Counter - 1, 2), Cells(Counter + 1, 2)).Merge
ws3.Range(Cells(Counter - 1, 3), Cells(Counter + 1, 3)).Merge
ws3.Range(Cells(Counter - 1, 4), Cells(Counter + 1, 4)).Merge
ws3.Range(Cells(Counter - 1, 5), Cells(Counter + 1, 5)).Merge
ws3.Range(Cells(Counter - 1, 6), Cells(Counter + 1, 6)).Merge
ws3.Range(Cells(Counter - 1, 7), Cells(Counter + 1, 7)).Merge
ws3.Range(Cells(Counter - 1, 8), Cells(Counter + 1, 8)).Merge
ws3.Cells(Counter - 1, 1).Value = ws1.Cells(j, 1).Value 'Overfører værdier fra sheet Indtastningsark til Sheet Vis_Oversigt
ws3.Cells(Counter - 1, 2).Value = ws1.Cells(j, 2).Value
ws3.Cells(Counter - 1, 3).Value = ws1.Cells(j, 3).Value
ws3.Cells(Counter - 1, 4).Value = ws1.Cells(j, 4).Value
ws3.Cells(Counter - 1, 5).Value = ws1.Cells(j, 7).Value
ws3.Cells(Counter - 1, 7).Value = ws1.Cells(j, 5).Value
ws3.Cells(Counter - 1, 8).Value = ws1.Cells(j, 6).Value
If PeriodeSlut < AfgangVaerft Then
PeriodeSkib = Periode
Else
PeriodeSkib = ws1.Cells(j, 6) - PeriodeStart
End If
ws3.Range(Cells(Counter, ((AnkomstVaerft - PeriodeStart) + 10)), Cells(Counter, PeriodeSkib + 10)).Interior.ColorIndex = 5 'Farver Rangen blå i kalenderen
If AnkomstDok <> "00:00:00" And AfgangDok <> "00:00:00" Then
If AnkomstDok >= PeriodeStart And AnkomstDok <= PeriodeSlut Then
If PeriodeSlut <= AfgangDok Then
PeriodeDokSlut = Periode
ElseIf PeriodeSlut >= AfgangDok Then
PeriodeDokSlut = ws1.Cells(j, 9) - PeriodeStart
End If
ws3.Range(Cells(Counter, ((AnkomstDok - PeriodeStart) + 10)), Cells(Counter, PeriodeDokSlut + 10)).Interior.ColorIndex = 43
ws4.Activate
Range(Cells(2, ((AnkomstDok - PeriodeStart) + 1)), Cells(2, PeriodeDokSlut + 1)).Value = 1
ws3.Activate
End If
End If
Counter = Counter + 3
ElseIf PeriodeStart >= AnkomstVaerft And PeriodeSlut <= AfgangVaerft And Dok = "Bedding" Then
ws3.Range(Cells(Counter - 1, 1), Cells(Counter + 1, 1)).Merge
ws3.Range(Cells(Counter - 1, 2), Cells(Counter + 1, 2)).Merge
ws3.Range(Cells(Counter - 1, 3), Cells(Counter + 1, 3)).Merge
ws3.Range(Cells(Counter - 1, 4), Cells(Counter + 1, 4)).Merge
ws3.Range(Cells(Counter - 1, 5), Cells(Counter + 1, 5)).Merge
ws3.Range(Cells(Counter - 1, 6), Cells(Counter + 1, 6)).Merge
ws3.Range(Cells(Counter - 1, 7), Cells(Counter + 1, 7)).Merge
ws3.Range(Cells(Counter - 1, 8), Cells(Counter + 1, 8)).Merge
ws3.Cells(Counter - 1, 1).Value = ws1.Cells(j, 1).Value
ws3.Cells(Counter - 1, 2).Value = ws1.Cells(j, 2).Value
ws3.Cells(Counter - 1, 3).Value = ws1.Cells(j, 3).Value
ws3.Cells(Counter - 1, 4).Value = ws1.Cells(j, 4).Value
ws3.Cells(Counter - 1, 5).Value = ws1.Cells(j, 7).Value
ws3.Cells(Counter - 1, 7).Value = ws1.Cells(j, 5).Value
ws3.Cells(Counter - 1, 8).Value = ws1.Cells(j, 6).Value
Range(Cells(Counter, 10), Cells(Counter, Periode + 10)).Interior.ColorIndex = 5
If AnkomstDok <> "00:00:00" And AfgangDok <> "00:00:00" Then
If PeriodeStart >= AnkomstDok And PeriodeSlut <= AfgangDok Then
Range(Cells(Counter, 10), Cells(Counter, Periode + 10)).Interior.ColorIndex = 43
ws4.Activate
Range(Cells(2, 1), Cells(2, Periode + 1)).Value = 1
ws3.Activate
End If
If AnkomstDok >= PeriodeStart And AnkomstDok <= PeriodeSlut Then
If PeriodeSlut <= AfgangDok Then
PeriodeDokSlut = Periode
ElseIf PeriodeSlut > AfgangDok Then
PeriodeDokSlut = ws1.Cells(j, 9) - PeriodeStart
End If
ws3.Range(Cells(Counter, ((AnkomstDok - PeriodeStart) + 10)), Cells(Counter, PeriodeDokSlut + 10)).Interior.ColorIndex = 43
ws4.Activate
ws4.Range(Cells(2, ((AnkomstDok - PeriodeStart) + 1)), Cells(2, PeriodeDokSlut + 1)).Value = 1
ws3.Activate
End If
If AnkomstDok < PeriodeStart And AfgangDok <= PeriodeSlut Then
Range(Cells(Counter, 10), Cells(Counter, (AfgangDok - PeriodeStart) + 10)).Interior.ColorIndex = 43
ws4.Activate
Range(Cells(2, 1), Cells(2, (AfgangDok - PeriodeStart) + 1)).Value = 1
ws3.Activate
End If
End If
Counter = Counter + 3
ElseIf AfgangVaerft >= PeriodeStart And AfgangVaerft <= PeriodeSlut And AnkomstVaerft < PeriodeStart And Dok = "Bedding" Then
ws3.Range(Cells(Counter - 1, 1), Cells(Counter + 1, 1)).Merge
ws3.Range(Cells(Counter - 1, 2), Cells(Counter + 1, 2)).Merge
ws3.Range(Cells(Counter - 1, 3), Cells(Counter + 1, 3)).Merge
ws3.Range(Cells(Counter - 1, 4), Cells(Counter + 1, 4)).Merge
ws3.Range(Cells(Counter - 1, 5), Cells(Counter + 1, 5)).Merge
ws3.Range(Cells(Counter - 1, 6), Cells(Counter + 1, 6)).Merge
ws3.Range(Cells(Counter - 1, 7), Cells(Counter + 1, 7)).Merge
ws3.Range(Cells(Counter - 1, 8), Cells(Counter + 1, 8)).Merge
ws3.Cells(Counter - 1, 1).Value = ws1.Cells(j, 1).Value
ws3.Cells(Counter - 1, 2).Value = ws1.Cells(j, 2).Value
ws3.Cells(Counter - 1, 3).Value = ws1.Cells(j, 3).Value
ws3.Cells(Counter - 1, 4).Value = ws1.Cells(j, 4).Value
ws3.Cells(Counter - 1, 5).Value = ws1.Cells(j, 7).Value
ws3.Cells(Counter - 1, 7).Value = ws1.Cells(j, 5).Value
ws3.Cells(Counter - 1, 8).Value = ws1.Cells(j, 6).Value
Range(Cells(Counter, 10), Cells(Counter, (AfgangVaerft - PeriodeStart) + 10)).Interior.ColorIndex = 5
If AnkomstDok <> "00:00:00" And AfgangDok <> "00:00:00" Then 'Tjekker om skibet er sat til at skulle i dok
If PeriodeStart >= AnkomstDok And AfgangDok >= PeriodeStart Then
Range(Cells(Counter, 10), Cells(Counter, (AfgangDok - PeriodeStart) + 10)).Interior.ColorIndex = 43
ws4.Activate
Range(Cells(2, 1), Cells(2, ((AfgangDok - PeriodeStart) + 1))).Value = 1
ws3.Activate
End If
If AnkomstDok >= PeriodeStart Then
ws3.Range(Cells(Counter, ((AnkomstDok - PeriodeStart) + 10)), Cells(Counter, (AfgangDok - PeriodeStart) + 10)).Interior.ColorIndex = 43
ws4.Activate
Range(Cells(2, ((AnkomstDok - PeriodeStart) + 1)), Cells(2, (AfgangDok - PeriodeStart) + 1)).Value = 1
ws3.Activate
End If
If AnkomstDok <= PeriodeStart And AfgangDok > PeriodeStart Then
Range(Cells(Counter, 10), Cells(Counter, (AfgangDok - PeriodeStart) + 10)).Interior.ColorIndex = 43
ws4.Activate
Range(Cells(2, 1), Cells(2, (AfgangDok - PeriodeStart) + 1)).Value = 1
ws3.Activate
End If
End If
Counter = Counter + 3
End If
Next j
End Sub
I've tried splitting the VBA into several, but I think there's a problem with the counter. I'm not a super user of codes, so I don't really know how to split this up into several Subs.
For a start you could replace these repeating blocks
ws3.Range(Cells(counter - 1, 1), Cells(counter + 1, 1)).Merge
ws3.Range(Cells(counter - 1, 2), Cells(counter + 1, 2)).Merge
ws3.Range(Cells(counter - 1, 3), Cells(counter + 1, 3)).Merge
ws3.Range(Cells(counter - 1, 4), Cells(counter + 1, 4)).Merge
ws3.Range(Cells(counter - 1, 5), Cells(counter + 1, 5)).Merge
ws3.Range(Cells(counter - 1, 6), Cells(counter + 1, 6)).Merge
ws3.Range(Cells(counter - 1, 7), Cells(counter + 1, 7)).Merge
ws3.Range(Cells(counter - 1, 8), Cells(counter + 1, 8)).Merge
ws3.Cells(counter - 1, 1).Value = ws1.Cells(j, 1).Value
ws3.Cells(counter - 1, 2).Value = ws1.Cells(j, 2).Value
ws3.Cells(counter - 1, 3).Value = ws1.Cells(j, 3).Value
ws3.Cells(counter - 1, 4).Value = ws1.Cells(j, 4).Value
ws3.Cells(counter - 1, 7).Value = ws1.Cells(j, 5).Value
ws3.Cells(counter - 1, 8).Value = ws1.Cells(j, 6).Value
ws3.Cells(counter - 1, 5).Value = ws1.Cells(j, 7).Value
With calls to a sub
Call TransferData(ws1.Cells(j, 1), ws3.Cells(counter - 1, 1))
Sub TransferData(rngFrom, rngTo)
Dim c As Long, arMap
For c = 1 To 8
rngTo.Offset(0, c - 1).Resize(3).Merge
Next
arMap = Array(0, 1, 2, 3, 6, 7, 4)
For c = 1 To 7
rngTo.Offset(0, arMap(c - 1)) = rngFrom.Offset(0, c - 1)
Next
End Sub
Not sure all the logic is correct but hopefully you get the idea
Option Explicit
Sub ProcessAllDocks()
Dim id, n As Long, targetRow As Long, LastRow As Long
'Call Lav_Kalender_Ny 'Get the macro that creates the calendar
' clear old data
With ThisWorkbook
With .Sheets("Vis_Oversigt")
' check valid dates
If IsDate(.Range("C4")) = False Or IsDate(.Range("E4")) = False Then
MsgBox "Date error in C4 or E4", vbExclamation
Exit Sub
ElseIf .Range("F6") > 400 Or .Range("F6") < 0 Then
MsgBox "F6 >400 or <0", vbExclamation
Exit Sub
End If
.Unprotect Password:="5980"
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
If LastRow >= 6 Then
.Range("A6:I" & LastRow).UnMerge
.Rows("6:" & LastRow + 2).Clear
End If
.Rows("3:" & LastRow + 2).RowHeight = 18
.Columns("A:A").NumberFormat = "@"
End With
With .Sheets("MIS")
.UsedRange.Clear
End With
End With
' process each dock
targetRow = 7
For Each id In Array("DOC III", "Bedding")
n = n + 1
Call ProcessDock(n, CStr(id), targetRow)
Next
MsgBox n & " docks processed", vbInformation
End Sub
Sub ProcessDock(n As Long, dockID, ByRef targetRow)
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim LastProjectRow As Long, r As Long, dock As String
Dim dtCalStart As Date, dtCalEnd As Date
Dim dtArrive As Date, dtDepart As Date ' yard
Dim dtEntry As Date, dtExit As Date ' dock
Dim bInYard As Boolean, bInDock As Boolean
With ThisWorkbook
Set ws1 = .Sheets("Indtastningsark") ' Project entry sheet
Set ws2 = .Sheets("Statistik") 'Statistics
Set ws3 = .Sheets("Vis_Oversigt") ' Overview
Set ws4 = .Sheets("MIS") '
End With
' Vis_Oversigt
With ws3
'start date for the calendar
dtCalStart = ws3.Cells(4, 3).Value
'end date for the calendar
dtCalEnd = ws3.Cells(4, 5).Value
End With
' ws1 - Project Entry Sheet. Sorted by DOK/KAJ
' Finds the number of entered projects on the Input sheet
LastProjectRow = ws1.Range("B" & Rows.Count).End(xlUp).Row
' Scan each project
For r = 3 To LastProjectRow
' check dock ID
If ws1.Cells(r, "G").Value = dockID Then 'Project's dock number or along quay
With ws1
dtArrive = .Cells(r, "E").Value 'Time ship arrives at shipyard
dtDepart = .Cells(r, "F").Value 'Time ship departs from shipyard
dtEntry = .Cells(r, "H").Value 'Time ship goes into dock (if it does this)
dtExit = .Cells(r, "I").Value 'Time ship leaves dock (if it does this)
End With
bInYard = False
bInDock = False
' Checks if Arrival in Dock ?? is within the period
If (dtArrive >= dtCalStart) And (dtArrive <= dtCalEnd) Then
bInYard = True
'Checks if the ship is scheduled to dock
If dtEntry <> "00:00:00" And dtExit <> "00:00:00" Then
'Checks if the arrival is within the calendar period
If dtEntry >= dtCalStart And dtEntry <= dtCalEnd Then
bInDock = True
End If
End If
' Check if Arrival is before Period and Departs after Period
ElseIf (dtArrive < dtCalStart) And (dtDepart > dtCalEnd) Then
bInYard = True
' color dock red=3
If dtEntry <> "00:00:00" And dtExit <> "00:00:00" Then
If dtEntry <= dtCalStart And dtExit >= dtCalEnd Then
bInDock = True
ElseIf dtEntry >= dtCalStart And dtEntry <= dtCalEnd Then
bInDock = True
ElseIf dtEntry < dtCalStart And dtExit <= dtCalEnd Then
bInDock = True
End If
End If
' Check if Arrival is before Period and Exits Dock within Period
ElseIf dtArrive < dtCalStart _
And dtExit >= dtCalStart And dtExit <= dtCalEnd Then
bInYard = True
'Tjekker om skibet er sat til at skulle i dok
'Checks whether the ship is set to dock
If dtEntry <> "00:00:00" And dtExit <> "00:00:00" Then
'Tjekker om kalenderperioden optræder i værftsperioden
'Checks whether the calendar period appears in the yard period
If dtEntry <= dtCalStart And dtExit >= dtCalEnd Then
bInDock = True
'Tjekker om ankomsten ligger inden for kalenderperioden
'Checks whether the arrival is within the calendar period
ElseIf dtEntry >= dtCalStart Then
bInDock = True
ElseIf dtEntry <= dtCalStart And dtExit > dtCalStart Then
bInDock = True
End If
End If
End If
' transfer data
If bInYard Then
Call TransferData(ws1.Cells(r, 1), ws3.Cells(targetRow - 1, 1))
' Fill Calendar with in yard dates 5-Blue
Call FillCalendar(5, ws3.Cells(targetRow, "J"), dtArrive, dtDepart, dtCalStart, dtCalEnd)
If bInDock Then
' Fill calendar with in dock dates red-3 and MIS with 1's
Call FillCalendar(3, ws3.Cells(targetRow, "J"), dtEntry, dtExit, dtCalStart, dtCalEnd, ws4.Cells(n, 1))
End If
targetRow = targetRow + 3
End If
End If
Next
MsgBox dockID & " Processed", vbInformation
End Sub
Sub TransferData(rngFrom, rngTo)
Dim c As Long, arMap
For c = 1 To 8
rngTo.Offset(0, c - 1).Resize(3).Merge
Next
arMap = Array(0, 1, 2, 3, 6, 7, 4)
For c = 1 To 7
rngTo.Offset(0, arMap(c - 1)) = rngFrom.Offset(0, c - 1)
Next
End Sub
Sub FillCalendar(iColor, rng, dtStart, dtEnd, dtCalStart, dtCalEnd, Optional rngMIS)
Dim dt1 As Date, dt2 As Date
' constrain start date to calendar start
dt1 = IIf(dtStart < dtCalStart, dtCalStart, dtStart)
' constrain end date to calendar end
dt2 = IIf(dtEnd > dtCalEnd, dtCalEnd, dtEnd)
' fill cells
rng.Offset(0, dt1 - dtCalStart).Resize(, dt2 - dt1 + 1).Interior.ColorIndex = iColor
' markup MIS
If IsMissing(rngMIS) Then
' skip
Else
rngMIS.Offset(0, dt1 - dtCalStart).Resize(, dt2 - dt1 + 1) = 1
End If
End Sub