Resultat fra samtidigt opslag i to tabeller

Det er vel et spørgsmål om at have et skema defineret over de relationer, der er mellem rollen og de respektive uddannelser.

Det kan udformes i VBA - evt. med anvendelse af en Userform (dialogboks) - men ikke nødvendigvis.

Du er velkommen med direkte kontakt via mail: pb@supertekst-it.dk - hvis der skal fremsendes filer eller andet.

Ja, jeg har som nævnt to skemaer, der beskriver hhv. hvilke kursusmoduler en rolle skal have, samt hvilke roller en person har. Jeg mangler "blot" at sammenkæde disse to tabeller, så når jeg tilføjer en rolle til en person, afkrydses de ekstra moduler, der nu skal uddannes i, for personen, automatisk.

Prøv at sende de to skemaer...

Const områdeNavn = "behov"

Dim områdeAdresse, startRæk, slutRæk, startKol, slutKol
Sub opbygModulDeltagelse()
    Application.ScreenUpdating = False
   
    områdeAdresse = hentDimensionerOmråde
   
    If områdeAdresse <> "" And InStr(områdeAdresse, ":") > 0 Then
        opsætDimensioner områdeAdresse
        sletAfkrydsninger                          'tidligere satte X
        gennemløbAfDeltagerne
       
        MsgBox ("Afkrydsning afsluttet")
    Else
        MsgBox ("Behovs-området er ikke fundet eller fejl heri")
    End If
   
    Application.ScreenUpdating = True
End Sub
Private Function hentDimensionerOmråde()
    For Each område In ActiveWorkbook.Names
        If LCase(område.Name) = områdeNavn Then
            hentDimensionerOmråde = område.RefersToRange.Address
            Exit Function
        End If
    Next
    hentDimensionerOmråde = ""
End Function
Private Sub opsætDimensioner(adr)
Dim p, St, Sl
    p = InStr(adr, ":")
    St = Mid(adr, 2, p - 2)
    Sl = Mid(adr, p + 2)
   
    p = InStr(St, "$")
    startKol = Left(St, p - 1)
    startRæk = Val(Mid(St, p + 1))
   
    p = InStr(Sl, "$")
    slutKol = Left(Sl, p - 1)
    slutRæk = Val(Mid(Sl, p + 1))
   
End Sub
Private Sub gennemløbAfDeltagerne()
Dim arkP, slutK
    Set arkP = ActiveWorkbook.Sheets("KursusPlanlægning")
    arkP.Select
   
    slutK = Asc(startKol) - 65
   
    With arkP
        For ræk = startRæk To slutRæk
            For kol = 2 To slutK
                If LCase(Cells(ræk, kol)) = "x" Then
                    hentRolleStart .Cells(2, kol), ræk
                End If
            Next kol
        Next ræk
   
    End With
End Sub
Private Sub hentRolleStart(rolle, deltagerRæk)
Dim rolleStart
    rolleStart = findRolle(rolle)
    If rolleStart > 0 Then
        kursusbehov = hentKursusBehov(rolleStart)
        markerKursusBehov kursusbehov, deltagerRæk
    End If
End Sub
Private Function findRolle(rolle)
Dim arkB, antalRæk
    Set arkB = ActiveWorkbook.Sheets("KursusBehov")
    arkB.Select
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    With arkB.Range("A1:A" & CStr(antalRæk))
        Set c = .Find(rolle, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findRolle = c.Row
        Else
            findRolle = 0
        End If
    End With
End Function
Private Function hentKursusBehov(startRæk)
Dim arkB, antalRæk, behov As String
    Set arkB = ActiveWorkbook.Sheets("KursusBehov")
    arkB.Select
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    behov = ""
   
    With arkB
        For ræk = startRæk To antalRæk
            If .Cells(ræk, 2) <> "" Then
                behov = behov + .Cells(ræk, 2) + "|"
            Else
                Exit For
            End If
        Next ræk
    End With
    hentKursusBehov = behov
End Function
Private Sub markerKursusBehov(behov, ræk)
Dim p, modul
    While InStr(behov, "|") > 0
        p = InStr(behov, "|")
        If p > 0 Then
            modul = Left(behov, p - 1)
            behov = Mid(behov, p + 1)
           
            afkrydsModul modul, ræk - 1
        End If
    Wend
End Sub
Private Function afkrydsModul(modul, ræk)
Dim arkP, kol, korriger
    Set arkP = ActiveWorkbook.Sheets("KursusPlanlægning")
    arkP.Select
   
    korriger = Asc(startKol) - 65
   
    With arkP.Range(Cells(2, startKol), Cells(2, slutKol))
        Set c = .Find(modul, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            kol = c.Column - korriger  'v/frysning af rude
            .Cells(ræk, kol) = "X"
        End If
    End With
End Function
Private Sub sletAfkrydsninger()
Dim arkP
    Set arkP = ActiveWorkbook.Sheets("KursusPlanlægning")
    arkP.Select
   
    arkP.Range(områdeAdresse).Select
    Selection.Clear
    arkP.Cells(startRæk, startKol).Select
End Sub

Super løsning!!! Skal du ikke angive det som et svar, så jeg kan lukke det og tildele point?

Det er så her...