VBA hjælp

Altså 50 checkbokse pr. nævnt kolonne

for i = 63 to 1122 // 400 checkbokse ??


...
Har du mulighed for at uploade filen eller sende (@-adresse under min profil)
...

Eksempel fra andet system:
Sub LinkCells()
  Dim myShape As Shape
  For Each myShape In ActiveSheet.Shapes
      If myShape.Type = msoFormControl Then
          If myShape.FormControlType = xlCheckBox Then
              myShape.Select
              Selection.LinkedCell = myShape.TopLeftCell.Address    '<----------
          End If
      End If
  Next
End Sub

Ja, det lyder lidt mærkeligt, jeg har bare kopieret hver ramme med to checkbokse og klikkede på den første for at se dens nummer, og på den sidste for at se dens. Måske er der noget jeg ikke har spottet, men nu har jeg sendt arket til dig.

Jeg håber du har en løsning.

Jeg tror løsningen muligvis ligger gemt i dette:

Sub insert_Checkbox()
Dim Introw As Integer
Dim LngTop As Long
For Introw = 26 To 52 Step 26
    ActiveSheet.CheckBoxes.Add(35, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$E$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
   
    ActiveSheet.CheckBoxes.Add(135, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$I$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"
   
    ActiveSheet.CheckBoxes.Add(235, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$Q$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
   
    ActiveSheet.CheckBoxes.Add(335, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$U$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"
   
    ActiveSheet.CheckBoxes.Add(435, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AC$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
   
    ActiveSheet.CheckBoxes.Add(535, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AG$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"
   
    ActiveSheet.CheckBoxes.Add(635, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AO$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
   
    ActiveSheet.CheckBoxes.Add(735, 40, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AS$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"
 
 
  ' Næste ActiveSheet.CheckBoxes.Add(135, 347, 78, 18).Select
  ' Hvordan laver man intervalskift på to "dimensioner"?
End Sub

Det vil sige at lade Excel vbaen selv indsætte checkboksene og linke cellen. Desværre kan jeg ikke regne ud hvordan jeg både får den til at skifte intervallet og skifte den højde checkboksene skal indsættes i.

Det er nummer to tal i parantes der også skal skifte sammen med IntRow og er sat til at være variablen LngTop. Kan man lave det så den stepper på to forskellige?

Jeg har Supertekst til at hjælpe på mail, men jeg deler gerne point ud til flere hvis der kommer en løsning andetstedsfra også.

Supertekst kom med en løsning på mit udkast, inkl. at tilrette nogle dumme kopieringsfejl.

Send et svar Supertekst :-)

Jeg fandt også selv løsningen baseret på det jeg havde lavet ovenfor:

Sub insert_Checkbox()
Dim Introw As Integer
Dim LngTop As Long
LngTop = 40

For Introw = 26 To 52 Step 26
    ActiveSheet.CheckBoxes.Add(35, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$E$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
 
    ActiveSheet.CheckBoxes.Add(135, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$I$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"
 
    ActiveSheet.CheckBoxes.Add(235, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$Q$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
 
    ActiveSheet.CheckBoxes.Add(335, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$U$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"
 
    ActiveSheet.CheckBoxes.Add(435, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AC$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
 
    ActiveSheet.CheckBoxes.Add(535, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AG$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"
 
    ActiveSheet.CheckBoxes.Add(635, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AO$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 1"
 
    ActiveSheet.CheckBoxes.Add(735, LngTop, 78, 18).Select
    With Selection
        .Value = xlOff
        .LinkedCell = "$AS$" & Introw
        .Display3DShading = False
    End With
    Selection.Characters.Text = "Hint 2"

    LngTop = LngTop + 300
Next

End Sub

Rem %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -2- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Sub findDubletter()
Dim myShape As Shape, antal As Integer
Dim LCadr, ræk As Integer

    ræk = 1
    Application.ScreenUpdating = False
   
    For Each myShape In ActiveSheet.Shapes
        If myShape.Type = msoFormControl Then
            If myShape.FormControlType = xlCheckBox Then
                myShape.Select
                LCadr = Selection.LinkedCell
               
                ActiveWorkbook.Sheets("Ark1").Activate
                ActiveSheet.Range("A" & ræk) = LCadr
                ræk = ræk + 1
               
                ActiveWorkbook.Sheets("Players").Activate
            End If
        End If
    Next
    MsgBox ræk - 1
End Sub
Rem %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - 3- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Sub sletDubletter()
Dim ræk As Integer, LCadr, antalRækker, ptAdr, tæller As Integer
    ActiveWorkbook.Sheets("Ark1").Activate
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    ptAdr = ActiveSheet.Range("A1")
    tæller = 1
   
    For ræk = 2 To antalRækker
        LCadr = ActiveSheet.Range("A" & ræk)
        If LCadr = ptAdr Then
            tæller = tæller + 1
        Else
            If tæller > 1 Then
           
                While tæller > 1
                    findOgSlet ptAdr
                    tæller = tæller - 1
                Wend
            End If
           
            ptAdr = LCadr
            tæller = 1
        End If
       
        ActiveWorkbook.Sheets("Ark1").Activate
    Next ræk
   
    If tæller > 1 Then
   
        While tæller > 1
            findOgSlet ptAdr
            tæller = tæller - 1
        Wend
    End If

   
Rem Optælling efter sletning
    antal = 0
   
    For Each myShape In ActiveSheet.Shapes
        If myShape.Type = msoFormControl Then
            If myShape.FormControlType = xlCheckBox Then
                antal = antal + 1
            End If
        End If
    Next

    MsgBox antal
End Sub
Private Sub findOgSlet(Adr)
    ActiveWorkbook.Sheets("Players").Activate

    For Each myShape In ActiveSheet.Shapes
        If myShape.Type = msoFormControl Then
            If myShape.FormControlType = xlCheckBox Then
                myShape.Select
               
                If Selection.LinkedCell = Adr Then
                    Selection.Delete
                    Exit Sub
                End If
            End If
        End If
    Next
End Sub
Rem %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -1- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Sub indsætLinkedCell()
Dim cbAdr, cbRæk As Integer, cbKolBogstav, cbKolTal As Integer, tabel As Variant
Dim tbAdr

    antal = 0
    Application.ScreenUpdating = False
   
    For Each myShape In ActiveSheet.Shapes
        If myShape.Type = msoFormControl Then
            If myShape.FormControlType = xlCheckBox Then
                myShape.Select
                cbAdr = myShape.TopLeftCell.Address
               
                Range(cbAdr).Select
                ActiveCell.Offset(rowoffset:=24, columnoffset:=1).Activate
                tbAdr = ActiveCell.Address
               
                myShape.Select
                Selection.LinkedCell = tbAdr

                antal = antal + 1
            End If
        End If
    Next
   
    MsgBox antal
End Sub