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
Automatisk give specifikke point udfra placering Af jernrosen3 i Excel 5 19/12/202410:24 Lige nu
Delvis udfyld en celle, baseret på en %-sats fra anden celle Af Brian Nielsen i Excel 2 16/12/202415:27 17/12/202422:03
Hjælp til formatering af excel ark. Af Nicholas i Excel 23 13/12/202412:32 18/12/202415:44
To x-akser men kun ét datasæt? Af TheLibrarian i Excel 1 10/12/202409:17 10/12/202410:35
Isolere en dato i tekst/tal Af jernrosen3 i Excel 7 09/12/202408:59 09/12/202410:38
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 går 22:16 Er "OneDrive" et "Must" ? Koster det penge ? Af Ikke-ekspert i Windows
I går 16:42 Windows Media Player - Hvilken version (Versioner) er gode til at afspille og kopiere ? Af Ikke-ekspert i Musik & videoafspillere
I går 12:54 Fejlfinding: Årsag til blank skærm og ingen BIOS fra Lenovo 90BH Af Mads i PC
I går 09:42 Outlook - kan ikke kopiere opgaver Af barth i Office & Kontorpakker
I går 00:26 Genhøre telefonsamtale Af anonym24 i Chat & Messaging
White papers
Flere white papers »


Premium
Teaser billede
Omsætning er steget med 100 millioner kroner på to år: Microsoft danske udviklingscenter har udbetalt milliarder i udbytte
Læs mere »
CISO Sarah Aalborg forlader Tivoli: Her er hendes planer for fremtiden
Sådan vil Domstolsstyrelsen nedbringe legacy og teknisk gæld: Her er den nye plan
Amerikansk spil-firma skal levere eSim-program til Forsvaret: Soldater skal lære at håndtere kampvogne på computer
Se alle »
Computerworld
Teaser billede
Dansk verdenshit fra 1992 bliver til ny international tv-serie
Læs mere »
Mord på it-profil truer San Franciscos status som tech-mekka: Byen er forvandlet til en zombie-by
Din MitID-app er netop blevet opdateret - her er de nye sikkerhedstiltag
Netværkstest: Første mesh-sæt med komplette WiFi 7-features sætter nye rekorder for dækning og hastighed
Se alle »
CIO
Teaser billede
Dansk headhunter: Dette spørgsmål bliver jeg næsten altid stillet, når jeg forsøger at rekruttere it-folk
Læs mere »
Software-selskabernes prisstigninger får nu danske virksomheder til at søge mod open source
AI er et falmende buzzword: Lad mig fluks dele en god og en dårlig nyhed
Region Sjælland vil skrive evighedskontrakt med Oracle-specialister: Står klar med 150 millioner kroner
Se alle »
Job & Karriere
Teaser billede
Microsoft klar med ny direktion for den danske forretning: Her er de nye direktører
Læs mere »
Merete Søby klar med nyt top-job efter pludselig exit fra Schultz: Her er hendes nye job
Linus Torvalds giver russiske Linux-udviklere sparket: Vil ikke have noget med dem at gøre
Twoday er rykket til et af de dyreste postnumre i Danmark – og det kan betale sig, siger topchef Lars Berthelsen
Se alle »
White paper
Teaser billede
Sæt turbo på din cloudperformance og minimér risikoen for DDoS-angreb
Læs mere »
Governance, Risk & Compliance: Knyt stærke bånd mellem forretning og sikkerhed
SAP: Skab værdi og minimér omkostninger med effektiv dokumenthåndtering
Cyberangreb bliver mere kostbare: Er du forberedt?
Se alle »

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