VBA Fra database til formular

Her er selve koden, som danner databasearket:

Public Sub BingoPladerTilBase()
Dim C(3) As Variant, UU(3) As Integer, X As Variant, U As Integer, I As Integer, Lille As Variant, Stor As Variant
Dim Rcount(2) As Integer, Kol(8) As Integer
Dim Plade(2, 8) As Variant, Base() As Variant

Randomize
Columns("A:AF").ClearContents
BlankFeltTekst = "BANKO"  ' ret blank felt tekst her
Q = InputBox("Hvor mange plader skal der genereres?", "Antal plader", 1)
ReDim Base(Q, 29)

'**************************************** Overskrifter ********************
I = 2  'Afgør hvilken kolonne Række/Kolonne overskrifterne skal starte

Base(0, 0) = "Kontrol"
Base(0, 1) = "Navn"
Base(0, 2) = "Opslag"

    For R = 1 To 3
        For K = 1 To 9
            I = I + 1
            Base(0, I) = "R" & R & "K" & K ' indsætter overskrifter
        Next
    Next
'**************************************** Overskrifter  slut ********************

    Lille = Array(1, 10, 20, 30, 40, 50, 60, 70, 80) ' mindste værdier
    Stor = Array(9, 19, 29, 39, 49, 59, 69, 79, 90)  ' største værdier
   
    R = 0
    T = 0
   
  For ny = 1 To Q

    '****************************** Tilpasser Antal på pladen ****************
    ' De 4 fordelingsmuligheder har forskellige sandsynligheder
    ' De kan placeres på 1554 forskellige måder
   
  Ford = Int(Rnd * 1554) + 1 ' Random fordeling
  If Ford < 84 + 756 + 630 + 84 Then A = 4
  If Ford < 84 + 756 + 630 Then A = 3
  If Ford < 84 + 756 Then A = 2
  If Ford < 84 Then A = 1
   
  Select Case A
    Case 1
    R1 = Array(3, 3, 3, 1, 1, 1, 1, 1, 1)
    Case 2
    R1 = Array(3, 3, 2, 2, 1, 1, 1, 1, 1)
    Case 3
    R1 = Array(3, 2, 2, 2, 2, 1, 1, 1, 1)
    Case 4
    R1 = Array(2, 2, 2, 2, 2, 2, 1, 1, 1)
  End Select
    '****************************** Blanding  start ****************
    For T = 0 To 8 ' 9 kolonner
KOL1:
      UK = Int(Rnd * 9) + 1 'tilfældig placering på Kolonner
  Kol(T) = UK - 1
    For Y = 0 To T - 1
      If Kol(Y) = UK - 1 Then GoTo KOL1
    Next Y
Next T
    '****************************** Blanding ****************
   
For T = 0 To 8 ' 9 kolonner

    For I = 0 To 2 ' antal rækker
   
Start1:
      U = Int(Rnd * 3) + 1 'tilfældig placering på række
  UU(I) = U
    For Y = 0 To I - 1
      If UU(Y) = U Then GoTo Start1
    Next Y
Start2:
        X = Int((Rnd() * (Stor(T) - Lille(T) + 1) + Lille(T)))
          If U > R1(Kol(T)) Then
                    Plade(I, R) = BlankFeltTekst  ' bart felt
          GoTo BarFelt
        End If
 
  For Y = 0 To I - 1
      If C(Y) = X Then GoTo Start2
    Next Y
  C(Y) = X
  Plade(I, R) = X
 
BarFelt:
  Next I
  R = R + 1
Next T
    '**************************** sortering 5 i hver række **************
TjekIgen:

For I = 0 To 2
Rcount(I) = 0
For j = 0 To 8
If IsNumeric(Plade(I, j)) Then
  Rcount(I) = Rcount(I) + 1
End If
Next
Next
    If Rcount(0) < 5 And Rcount(1) > 5 Then Fra = 1: til = 0: GoTo FlytPlads
    If Rcount(0) < 5 And Rcount(2) > 5 Then Fra = 2: til = 0: GoTo FlytPlads
    If Rcount(1) < 5 And Rcount(0) > 5 Then Fra = 0: til = 1: GoTo FlytPlads
    If Rcount(1) < 5 And Rcount(2) > 5 Then Fra = 2: til = 1: GoTo FlytPlads
    If Rcount(2) < 5 And Rcount(0) > 5 Then Fra = 0: til = 2: GoTo FlytPlads
    If Rcount(2) < 5 And Rcount(1) > 5 Then Fra = 1: til = 2: GoTo FlytPlads
  GoTo AltOk
 
FlytPlads:
  For Iv = 0 To 8
    If IsNumeric(Plade(Fra, Iv)) Then  ' rækken med mere end 5
      If Plade(til, Iv) = BlankFeltTekst Then  'rækken med mindre end 5 og skal være blank
      Plade(til, Iv) = Plade(Fra, Iv)  ' flytter række
      Plade(Fra, Iv) = BlankFeltTekst    ' skriver blank tekst
      GoTo TjekIgen
      End If
  End If
  Next
GoTo TjekIgen
'**************************** sortering lodret stigende **************
AltOk:
For v = 0 To 8
  For I = 0 To 2
  If Plade(I, v) = BlankFeltTekst Then GoTo Tekst1
 
    For Iv = 0 To 1
    If Plade(Iv, v) = BlankFeltTekst Then GoTo Tekst2
      If Plade(I, v) < Plade(Iv, v) Then
        temp = Plade(I, v)
      Plade(I, v) = Plade(Iv, v)
      Plade(Iv, v) = temp
    End If
Tekst2:
    Next Iv
Tekst1:
  Next I
  Next
 
'**************************** sortering slut **************
Base(ny, 0) = ny + 100      'Kontrolciffer
   
    For I = 1 To 9
        Base(ny, I + 2) = Plade(0, I - 1)
    Next
   
    For I = 10 To 18
        Base(ny, I + 2) = Plade(1, I - 10)
    Next
   
    For I = 19 To 27
        Base(ny, I + 2) = Plade(2, I - 19)
    Next
    'Base(ny,30)=xxx    'Indsætter beregningsformel efter arket - husk at Q skal ændres
  R = 0
Next ny

Range(Cells(1, 1), Cells(Q + 1, 30)) = Base
End Sub

Et forsøg, men uden formatering af celler

Sub udskrift()
    Dim A4 As Integer, Start As Integer, AntalPlader As Integer, Base As Variant
    A4 = 0
    PerArk = 0
  AntalPlader = Worksheets("Database").Range("A65536").End(xlUp).Row - 1
     
PerArk:
    PerArk = InputBox("Hvor mange plader skal der være på hvert A4-ark?", "Antal plader pr. ark", 2)
    If PerArk > 4 Or PerArk < 1 Then
        MsgBox "Antal plader pr. A4-ark skal være mellem 1 og 4"
        GoTo PerArk
    End If
    A4 = Round(AntalPlader / PerArk)
    If A4 * PerArk < AntalPlader Then A4 = A4 + 1
    Base = Worksheets("database").Range("A2:AD" & AntalPlader)
   
    Worksheets("Udskrift").Cells.Delete Shift:=xlUp
    Start = 6
    For g = 1 To A4 Step PerArk
    For h = 0 To PerArk - 1
  ' Opdeles i 3 etaper, da hver plade indeholder 3 rækker
    For I = 1 To 9
        Worksheets("Udskrift").Cells(Start, I) = Base(g + h, I + 3)
    Next
    For I = 10 To 18
      Worksheets("Udskrift").Cells(Start + 1, I - 9) = Base(g + h, I + 3)
    Next
    For I = 19 To 27
      Worksheets("Udskrift").Cells(Start + 2, I - 18) = Base(g + h, I + 3)
    Next
      Worksheets("Udskrift").Cells(Start + 3, 8) = "Kontrol"
      Worksheets("Udskrift").Cells(Start + 3, 9) = Base(g + h, 1)
    Start = Start + 7
    Next h
  ' Indsæt sluttekst Udskrift
  ' Print
  Worksheets("Udskrift").Rows(Start).Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
  Start = Start + 5
    Next g
End Sub

Takker kabbak.
Der er dog en eller anden fejl i tælleren.
Den får ikke alle poster med.
G-løkken skal vel bare steppe 1? Men der må også være noget andet galt.

Hvordan med en evt. formatering.
Bare en tynd streg om alle celler med indhold samt mulighed for at køre de "blanke" felter i en anden skriftstørrelse.
Det var ikke en del af det oprindelige spørgsmål, så jeg forhøjer pointene lidt.

Sub udskrift()
    Dim A4 As Integer, Start As Integer, AntalPlader As Integer, Base As Variant
    A4 = 0
    PerArk = 0
  AntalPlader = Worksheets("Database").Range("A65536").End(xlUp).Row - 1
     
PerArk:
    PerArk = InputBox("Hvor mange plader skal der være på hvert A4-ark?", "Antal plader pr. ark", 2)
    If PerArk > 4 Or PerArk < 1 Then
        MsgBox "Antal plader pr. A4-ark skal være mellem 1 og 4"
        GoTo PerArk
    End If
    Base = Worksheets("database").Range("A2:AD" & AntalPlader + 1)
   
    Worksheets("Udskrift").Cells.Delete Shift:=xlUp
    Start = 6
    For G = 1 To AntalPlader Step PerArk
    For h = 0 To PerArk - 1
  ' Opdeles i 3 etaper, da hver plade indeholder 3 rækker
    For I = 1 To 9
        Worksheets("Udskrift").Cells(Start, I) = Base(G + h, I + 3)
    Next
    For I = 10 To 18
      Worksheets("Udskrift").Cells(Start + 1, I - 9) = Base(G + h, I + 3)
    Next
    For I = 19 To 27
      Worksheets("Udskrift").Cells(Start + 2, I - 18) = Base(G + h, I + 3)
    Next
      Worksheets("Udskrift").Cells(Start + 3, 8) = "Kontrol"
      Worksheets("Udskrift").Cells(Start + 3, 9) = Base(G + h, 1)
    Start = Start + 7
    If G + (h + 1) > AntalPlader Then Exit Sub
   
    Next h
  ' Indsæt sluttekst Udskrift
  ' Print
  Worksheets("Udskrift").Rows(Start).Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
  Start = Start + 5
    Next G
End Sub


rettet

med formatering af celler

Sub udskrift()
    Dim A4 As Integer, Start As Integer, AntalPlader As Integer, Base As Variant
    A4 = 0
    PerArk = 0
    StorSkrift = 30 'Maks 30
    LilleSkrift = 8
  AntalPlader = Worksheets("Database").Range("A65536").End(xlUp).Row - 1
     
PerArk:
    PerArk = InputBox("Hvor mange plader skal der være på hvert A4-ark?", "Antal plader pr. ark", 2)
    If PerArk > 4 Or PerArk < 1 Then
        MsgBox "Antal plader pr. A4-ark skal være mellem 1 og 4"
        GoTo PerArk
    End If
    Application.ScreenUpdating = False
    Base = Worksheets("database").Range("A2:AD" & AntalPlader + 1)
    Worksheets("Udskrift").Cells.Delete Shift:=xlUp
    Start = 6
    For G = 1 To AntalPlader Step PerArk
    For h = 0 To PerArk - 1
  ' Opdeles i 3 etaper, da hver plade indeholder 3 rækker
    For I = 1 To 9
        Worksheets("Udskrift").Cells(Start, I) = Base(G + h, I + 3)
    Next
    For I = 10 To 18
      Worksheets("Udskrift").Cells(Start + 1, I - 9) = Base(G + h, I + 3)
    Next
    For I = 19 To 27
      Worksheets("Udskrift").Cells(Start + 2, I - 18) = Base(G + h, I + 3)
    Next
      Worksheets("Udskrift").Cells(Start + 3, 8) = "Kontrol"
      Worksheets("Udskrift").Cells(Start + 3, 9) = Base(G + h, 1)
      Range(Cells(Start, 1), Cells(Start + 2, 9)).Select
      Selection.Borders.LineStyle = xlContinuous
            With Selection
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
        End With
        For Each C In Selection
        If IsNumeric(C) Then
        C.Font.Size = StorSkrift
        Else
          C.Font.Size = LilleSkrift
        End If
        Next
    Start = Start + 7
    If G + (h + 1) > AntalPlader Then GoTo Slut
        Next h
  ' Indsæt sluttekst Udskrift
  ' Print
  Worksheets("Udskrift").Rows(Start).Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
  Start = Start + 5
    Next G
Slut:
Application.ScreenUpdating = True
End Sub

Præcis!
Smid et svar.

et svar

Tjek lige http://www.eksperten.dk/spm/441442