22. december 2003 - 11:49Der er
8 kommentarer og 1 løsning
VBA Fra database til formular
Jeg sætter endnu engang fast i min banko VBA-kode :-)
Jeg har et ark "Database" med 30 kolonner og x antal rækker dannet ud fra nedenstående kode.
På et andet ark "Udskrift" har jeg en formular, som skal udfyldes udfra data fra databasen.
Brugeren skal kunne vælge, hvor mange plader (fra 1 til 4) der skal udskrives på hvert ark. D.v.s. at hvis der f.eks. der 30 poster(bankoplader) i databasen, og brugeren vælger 3 plader pr. udskriftsside, så skal der udskrives 10 sider.
Jeg har foreløbigt eksperimenteret mig frem til følgende:
Sub udskrift() Dim A4 As Integer A4 = 0 PerArk = 0
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 'Worksheets("database").Select 'Range("A2:AD" & AntalPlader + 1).Select 'For g = 1 To A4 'For h = 1 To PerArk 'For i = 1 to 3 Opdeles i 3 etaper, da hver plade indeholder 3 rækker
'Next i 'Next h 'Indsæt sluttekst 'Print 'Next g End Sub
Den første plade skal nok først starte i række 5, da der på hver side skal være plads til en "header".
Mellem hver plade (som består at 3 rækker á 9 celler) skal der vel være 3 blanke rækker.
Kontrolcifferet skal højrespilles under hver plade.
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
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
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
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
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.
