CIO Tech Eksperten IT-JOB IT-Kurser Events Podcast Søg
Cookie ikon
Avatar billede HHA Professor
13. november 2024 - 13:48 Der er 7 kommentarer og
1 løsning

Opdele VBA kode, som er for lang

Hejsa,

Hvordan opdeler man en VBA kode som er for lang?
Nedenfor viser jeg et udklip af koden. Den fylder meget, fordi den skal gentage det neden for som er Dok III, for de andre dokker og nu ville jeg tilføje en bedding, men så blev proceduren for lang.
Men jeg har prøvet at sætte beddingen ind som en anden Sub, men tror ikke den læser den.....

Sub Booking()

    Application.ScreenUpdating = False

    Call Lav_Kalender_Ny 'Henter macroen som laver kalenderen
     
    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
   
    ActiveSheet.Unprotect Password:="5980"
   
    PeriodeStart = ws3.Cells(4, 3).Value 'PeriodeStart er start datoen for kalenderen (indtastes på Vis_Oversigt)
    PeriodeSlut = ws3.Cells(4, 5).Value 'PeriodeSlut er slutdatoen for kalenderen (Indtastes på Vis_Oversigt)
    Periode = ws3.Cells(4, 6) 'Perioden er det antal dage som kalenderen løber
   
    Counter = 7 ' Counter er sat til 7, da projekterne skal indføres fra og med række 7 på Vis_Oversigt
    ProjectCount = ws1.Range("B" & Rows.Count).End(xlUp).Row 'Finder antallet af indførte projekter på sheet Indtastningsark
    RowCount = ws3.Range("B" & Rows.Count).End(xlUp).Row 'Finder antallet af indførte rækker på sheet Vis_Oversigt
   
    ws3.Range(Cells(6, 1), Cells(RowCount, 9)).UnMerge
    ws3.Range(Cells(6, 1), Cells(RowCount, 9)).Clear 'Sletter hentede projekter på 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

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Her følger algortimen for Pre Booking - Dok III
   
    'Følgende algoritme kontrollerer om projektet ligger inden for PeriodeStart og PeriodeSlut og henter dem over i sheet Vis_Oversigt fra Sheet Indtastningsark. Sorteret efter DOK/KAJ
    For j = 3 To ProjectCount
        AnkomstVaerft = ws1.Cells(j, 5).Value 'Tidspunkt projekt ankommer til værft
        AfgangVaerft = ws1.Cells(j, 6).Value 'Tidspunkt skib afgår fra vaerft
        Dok = ws1.Cells(j, 7).Value 'Projektets doknummer eller langs kaj
        AnkomstDok = ws1.Cells(j, 8).Value 'Tidspunkt projekt går i dok(såfremt det gør dette)
        AfgangDok = ws1.Cells(j, 9).Value 'Tidspunkt projekt kommer ud af dok(såfremt det gør dette)
        CounterStatistikDok = 0

        If (AnkomstVaerft >= PeriodeStart And AnkomstVaerft <= PeriodeSlut And Dok = "DOK III") Then 'Tjekker om ankomst ligger inden for perioden og at skibet skal i DOK 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 '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 'Tjekker om skibet afgår værft efter kalender slutdato(dette gøres for at undgå markering ud over kalenderens område)
                PeriodeSkib = Periode 'PeriodeSkib defineres til at være samme tidsrum som kalenderen(alene for at undgå markering ud over kalenderens område)
            Else
                PeriodeSkib = ws1.Cells(j, 6) - PeriodeStart 'Hvis skibet afgår værft før kalenderen slutter, er PeriodeSkib defineret til at være fra startdato af kalender til afgang skib
            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 'Tjekker om skibet er sat til at skulle i dok
                If AnkomstDok >= PeriodeStart And AnkomstDok <= PeriodeSlut Then 'Tjekker om ankomsten ligger inden for kalenderperioden
                    If PeriodeSlut <= AfgangDok Then 'Tjekker om dokperioden løber hele kalenderperioden
                        PeriodeDokSlut = Periode
                    ElseIf PeriodeSlut >= AfgangDok Then 'tjekker om dokperioden udløber før kalenderperioden
                        PeriodeDokSlut = ws1.Cells(j, 9) - PeriodeStart
                    End If
               
                ws3.Range(Cells(Counter, ((AnkomstDok - PeriodeStart) + 10)), Cells(Counter, PeriodeDokSlut + 10)).Interior.ColorIndex = 3
                ws4.Activate
                Range(Cells(1, ((AnkomstDok - PeriodeStart) + 1)), Cells(1, PeriodeDokSlut + 1)).Value = 1
                ws3.Activate
                'CounterStatistikDok = PeriodeDokSlut - (AnkomstDok - PeriodeStart) 'TY

                End If
            End If
       
        Counter = Counter + 3 'rykker counter og springer linje over

        ElseIf PeriodeStart > AnkomstVaerft And PeriodeSlut < AfgangVaerft 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, Periode + 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 PeriodeSlut <= AfgangDok Then 'Tjekker om kalenderperioden optræder i værftsperioden
                    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 'Tjekker om ankomsten ligger inden for kalenderperioden
                    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

Og herunder næsten det samme som oven for, for de næste dokke.




Jeg har prøvet at lave Sub for Bedding med og uden det der er oven for linjen med teksten: 'Her følger algortimen for Bedding


Sub for bedding:

Sub Bedding()


Application.ScreenUpdating = False

    'Call Lav_Kalender_Ny 'Henter macroen som laver kalenderen
     
    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 'Tidspunkt projekt ankommer til værft
        AfgangVaerft = ws1.Cells(j, 6).Value 'Tidspunkt skib afgår fra vaerft
        Dok = ws1.Cells(j, 7).Value 'Projektets doknummer eller langs kaj
        AnkomstDok = ws1.Cells(j, 8).Value 'Tidspunkt projekt går i dok(såfremt det gør dette)
        AfgangDok = ws1.Cells(j, 9).Value 'Tidspunkt projekt kommer ud af dok(såfremt det gør dette)

        If (AnkomstVaerft >= PeriodeStart And AnkomstVaerft <= PeriodeSlut And Dok = "Bedding") Then 'Tjekker om ankomst ligger inden for perioden og at skibet skal i DOK 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 '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 'Tjekker om skibet afgår værft efter kalender slutdato(dette gøres for at undgå markering ud over kalenderens område)
                PeriodeSkib = Periode 'PeriodeSkib defineres til at være samme tidsrum som kalenderen(alene for at undgå markering ud over kalenderens område)
            Else
                PeriodeSkib = ws1.Cells(j, 6) - PeriodeStart 'Hvis skibet afgår værft før kalenderen slutter, er PeriodeSkib defineret til at være fra startdato af kalender til afgang skib
            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 'Tjekker om skibet er sat til at skulle i dok
                If AnkomstDok >= PeriodeStart And AnkomstDok <= PeriodeSlut Then 'Tjekker om ankomsten ligger inden for kalenderperioden
                    If PeriodeSlut <= AfgangDok Then 'Tjekker om dokperioden løber hele kalenderperioden
                        PeriodeDokSlut = Periode
                    ElseIf PeriodeSlut >= AfgangDok Then 'tjekker om dokperioden udløber før kalenderperioden
                        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 'rykker counter og springer linje over

        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 '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, Periode + 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 PeriodeSlut <= AfgangDok Then 'Tjekker om kalenderperioden optræder i værftsperioden
                    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 'Tjekker om ankomsten ligger inden for kalenderperioden
                    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 '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 = 43
                   
                    ws4.Activate
                    Range(Cells(2, 1), Cells(2, ((AfgangDok - PeriodeStart) + 1))).Value = 1
                    ws3.Activate
                   
                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 = 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
Avatar billede MaxZpaD Guru
13. november 2024 - 14:35 #1
Har du evt. prøvet at opdele i flere kodemoduler og ikke flere Subs i samme kodemodul?
Avatar billede HHA Professor
13. november 2024 - 14:42 #2
#1
Nej, ovenstående kode, er delt nede midt på, der hvor den hedder Sub Bedding.
Har fundet ud af at den læser den (lavede en fejl i den med vilje og den fandt den), men den tilføjer ikke noget til kalenderen/oversigten fra Sub Bedding.
Hele koden er ca 1800 linjer og vil meget gerne dele den op.

Jeg kæmper med at dele koden op og få den til at virke.
Så mit problem er at få den til at køre de stumper kode, jeg ligger over i nye Sub...
Det er det jeg har brug for hjælp til.
Avatar billede MaxZpaD Guru
13. november 2024 - 14:56 #3
Kan det være, at du skal gøre dine variable Public i stedet for, at de kun gælder inden for hver Sub?

Fx ProjectCount:
Den dimensionerer og værdisætter du i Sub Booking().

Når du så kalder Bedding, dimensioneres en ny variabel med samme navn, men den får ikke sat en værdi (så vidt jeg kan se). Dette betyder, at "For j = 3 To ProjectCount" i Bedding håndteres som "fra 3 til 0", hvilket vil betyde, at loop'et overhovedet ikke udføres.
Avatar billede HHA Professor
13. november 2024 - 15:17 #4
Det rækker mine evner ikke til at forstå, det du foreslår.
Men kan godt forstå, det du mener med at den måske ikke tæller og så giver den selvfølgelig heller ingen data.

Prøvede lige at skifte j om til k i Sub Bedding.
Det ændrede ikke noget.

Så hvordan jeg skal lave det, du foreslår, aner jeg ikke. Det skal nok skæres mere ud i pap til mig 🙃
Avatar billede MaxZpaD Guru
13. november 2024 - 15:33 #5
Dine variable bliver lige nu erklæret i hver enkelt Sub med linjerne "Dim xxx As yyy" osv. Dette gør dem kun tilgængelige inden for den enkelte Sub.

Hvis disse variable skal kunne anvendes/deles af mere end én Sub i kodemodulet, skal du flytte dimensioneringen op øverst i kodemodulet og fjerne den i de enkelte Subs.

Fx sådan her:

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

Sub Booking()
.
.
.
End Sub

Sub Bedding()
.
.
.
End Sub
Avatar billede HHA Professor
13. november 2024 - 15:48 #6
Det vil sige at jeg skal flytte alle dokke ud til enkelt e subs, før det vil virke?
Jeg har prøvet, som jeg beskriver i første opslag, at undlade at have hele den første del med i Sub Bedding, ned til  'Her følger algortimen for Bedding.

Hvis jeg har forstået koden rigtigt, så kører den counter for Dok III og render ned gennem det andet faneblad og finder det der har med Dok III at gøre.
Den fortsætter så til Dok II og gør det samme osv.
Avatar billede MaxZpaD Guru
13. november 2024 - 16:09 #7
Nu er jeg jo ikke lige så dybt inde i din VBA-kode og arkene i Excel-filen, som du selv er, så det, jeg foreslår, er ud fra generelle principper for kodning med VBA. Derfor kan det også være svært for mig at gennemskue, om du skal flytte alle dokke ud i enkelte Subs, eller om du kan håndtere flere i samme Sub, så længe størrelsen på kodemodulet ikke overstiger 64K (lidt over 65.000 karakterer), som er begrænsningen, så vidt jeg har forstået.

Det, som er afgørende, er, at alle relevante variable er tilgængelige for alle dine Subs, som du vil kalde i en given rækkefølge.

Det næste er så, at dine delte variable skal have de rigtige værdier, når du går fra én Sub til en anden. Hvis fx ProjectCount er forskellig fra Sub til Sub (eller fra Dok til Dok), så skal værdien stadig sættes i hver Sub eller for hver Dok.

Hvis fx Counter bare skal køre videre fra dér, hvor den var kommet til i den foregående Sub, så skal den ikke sættes igen, osv.

Håber, det er forståeligt forklaret :-)
Avatar billede HHA Professor
19. november 2024 - 08:25 #8
Hejsa,

Løsningen blev dette:

Slette alle de steder hvor jeg havde dette:
  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

Kalde en ny Sub:
Call TransferData(ws1.Cells(j, 1), ws3.Cells(counter - 1, 1))

Nye 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

Så virkede det til UG.

Stor tak til MaxZpaD som forsøgte at få en nybegynder som mig på rette spor 👍
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Excel kurser
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.
Se alle Excel kurser

Flere spørgsmål fra Excel kategorien

Titel Indlæg Oprettet Seneste aktivitet
Ændre nuller til ovenstående tekst Af boro23 i Excel 4 I går 10:44 I går 12:08
HVIS med datoer Af HHA i Excel 6 I går 08:31 I går 12:51
Numerisk liste Af AND i Excel 8 19/11/202414:05 19/11/202423:31
Ændre nuller til ovenstående tal Af boro23 i Excel 3 19/11/202409:39 19/11/202411:51
Addition af celler, som er formatteret "tt.mm" Af FinBalance i Excel 5 18/11/202414:14 19/11/202414:11
Se alle spørgsmål i kategorien Opret spørgsmål

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Opret Log ind

Du kan også logge ind via nedenstående tjenester



Alle kategorier på Eksperten
Seneste spørgsmål Seneste aktivitet
I dag 18:03 Kan en kombinationsbox formateres om til en text box og omvendt Af per2edb i Access
I dag 12:41 Standard kontoplan til dynamics business central Af prof2004 i Økonomiprogrammer
I går 21:03 Kan ikke se mine cromecasts Af Malm i Browsere
I går 19:06 driver til platonic 3200, på win 10 Af Novice-1 i Windows
I går 17:22 Gør password synligt Af valsbol i Andet software
White papers
Flere white papers »


Premium
Teaser billede
Københavns Kommune ansætter sin første CISO nogensinde: Skal bygge it-afdelingen op omkring 45.000 ansatte
Læs mere »
Ny EU-sikkerhedslov er offentliggjort: Nu er nedtællingen i gang
Melder alt klart med kæmpe it-projekt: Budget er steget med næsten 30 procent undervejs
Konsulenthus vil rulle Microsoft 365 Copilot ud til 200.000 ansatte
Se alle »
Computerworld
Teaser billede
Microsofts nye pc er ekstrem billig – men kan blive ekstrem sikker og fleksibel
Læs mere »
Test: Audi Q6 er en super fed SUV - men gør dig selv en tjeneste og kast flere penge efter den
Det vrimler frem med gratis-alternativer til ChatGPT Plus – her er de bedste af dem
Test: Prøv kun disse B&O-hovedtelefoner, hvis du har råd
Se alle »
CIO
Teaser billede
Danske sygehuse når ikke at opgradere tusindvis af computere til Windows 11 i tide: Får konsekvenser for it-sikkerheden
Læs mere »
Kæmpe-opgave for Danske Bank har banet vej for fuldautomatiseret migrering til cloud: Nu udbredes metoden i hele AWS
Stor sag mod Microsoft kan være på vej: Beskyldes for at låse Azure-kunder fast med ulovlige metoder
Konsulenthus vil rulle Microsoft 365 Copilot ud til 200.000 ansatte
Se alle »
Job & Karriere
Teaser billede
Microsoft klar med ny direktion for den danske forretning: Her er de nye direktører
Læs mere »
Tre Norlys-topchefer fratræder med omgående virkning: Internet-forretningen er udfordret - vil have mere fart i integrationen af Telia Danmark
Efter skelsættende møde med sportscoach: Stor dansk it-arbejdsplads indfører fredags-fri og isbade i arbejdstiden
Linus Torvalds giver russiske Linux-udviklere sparket: Vil ikke have noget med dem at gøre
Se alle »
White paper
Teaser billede
Sikkerhed uden grænser: Cisco Hypershield
Læs mere »
SMB og cybertrusler: Brug sikkerhedsressourcerne optimalt
Vær proaktiv og prioritér IT-sikkerheden – før det er for sent
Sådan får du overblik og beskytter dine cloudapplikationer
Se alle »

Events
Flere events »
White papers
Flere white papers »
IT-Kurser
Se alle vores it-kurser »