Excel

Du kan nok ikke uploade din projektmappe - men kan du fremstille en model, der illustrerer virkeligheden?

og så velkommen til eksperten.

Hej😊
Det kan du tro. Jeg er taget fravarbejde for i dag. Jeg sender modellen i morgen tidlig.

På forhånd tak.

Mvh. Martin Schougaard.

Ok

Hej supertekst;

Jeg er en smule i tvivl om, hvad du præcist mener med, om jeg kan lave en model, som illustrerer min forespørgsel?

Jeg har i et regneark nu lavet en forsimplet udgave af den faktiske projektmappe, jeg arbejder med. Men hvordan kan jeg vise dig den??

Mvh. Martin

Hej

Du kan uploade den eller sende den direkte - @-adresse under min profil.

Dim antalRækker As Integer, antalKolonner As Integer
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Application.ScreenUpdating = False
   
    If Target.Address = "$A$1" Then
        Cancel = True
        Range("B1").Select
        houseKeeping
        opbygData
    End If
   
    ActiveWorkbook.Sheets("Grafikdata").Activate
End Sub
Private Sub houseKeeping()
    findAntalRækkerOgKolonner
   
    ActiveSheet.Range(Cells(2, 2), Cells(antalRækker, antalKolonner)).ClearContents
End Sub
Private Sub findAntalRækkerOgKolonner()
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
    antalKolonner = ActiveCell.SpecialCells(xlLastCell).Column
End Sub
Private Sub opbygData()
Dim ræk As Integer, cprNr As String, udslusetTil As String, Akasse As String
    ActiveWorkbook.Sheets("Grunddata").Activate
    findAntalRækkerOgKolonner
   
    For ræk = 2 To antalRækker
        cprNr = ActiveSheet.Range("D" & ræk)
        udslusetTil = ActiveSheet.Range("F" & ræk)
        Akasse = findAkasse(Sheets("Andet"), "D2:D" & antalRækker, cprNr)
       
        If Akasse <> "" Then
            indsætGrafikData udslusetTil, Akasse
        End If
       
        ActiveWorkbook.Sheets("Grunddata").Activate
        findAntalRækkerOgKolonner
       
    Next ræk
End Sub
Private Function findAkasse(arkNavn, område, id)
Dim c, række As Integer
    With arkNavn.Range(område)
        Set c = .Find(id, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            række = c.Row
            findAkasse = Sheets("Andet").Cells(række, 5)
        Else
            findAkasse = ""
        End If
    End With
End Function
Private Sub indsætGrafikData(udslusetTil, Akasse)
Dim kol As Integer, ræk As Integer
    ActiveWorkbook.Sheets("GrafikData").Activate
        If udslusetTil = "" Then
            udslusetTil = "???"
        End If
       
        findAntalRækkerOgKolonner
        For ræk = 2 To antalRækker
            If LCase(Range("A" & ræk)) = LCase(udslusetTil) Then
                For kol = 2 To antalKolonner
                    If LCase(Cells(1, kol)) = LCase(Akasse) Then
                        Cells(ræk, kol) = Cells(ræk, kol) + 1
                        Exit Sub
                    End If
                Next kol
            End If
        Next ræk
End Sub

Smukt arbejde - tak for det;-)

Selv tak..