Diskuze: Excel - úprava makra

Jan Novák

Člen

Jan Novák :14.2.2017 14:07

Ahoj všem

V práci jsem "podědil" generátor testových otázek v excelu a potřeboval bych radu. Makro dělá to, že náhodně generuje ze seznamu otázek a odpovědí, které jsou na jednom listu test. Tento vygenerovaný přenese jako podklad k tisku na další list. Problém je, pokud délka otázky nebo odpovědi přesáhne 265 (266?) znaků. V tomto případě se sice vše vygeneruje správně, ale text se ořízne na tuto hodnotu. Poradil by někdo kde a jak makro upravit prosím?
Makro níže:

Public Radek As Integer
Public Radek2 As Integer
Public Radek3 As Integer
Public Otazka As Integer

Function MySort()
Worksheets("Temp").Sort.SortFields.Clear
Worksheets("Temp").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Worksheets("Temp").Sort
.SetRange Range("A1:B500")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Function

Function Okruh(NazevOkruhu, PocetOtazek)
Randomize
Worksheets("Temp").Range("A1:B500").ClearContents
Worksheets(NazevOkruhu).Range("I1:L500").ClearContents
J = 0
For I = 1 To 500
Adr = I + 3
If Worksheets(NazevOkruhu).Cells(Adr, 1).Value = 1 Then
MaxPocet = 0
Chyba = 0
If Worksheets(NazevOkruhu).Cells(Adr, 5).Value > "" Then
MaxPocet = MaxPocet + 1
End If
If Worksheets(NazevOkruhu).Cells(Adr, 6).Value > "" Then
If MaxPocet = 0 Then Chyba = 1
MaxPocet = MaxPocet + 1
End If
If Worksheets(NazevOkruhu).Cells(Adr, 7).Value > "" Then
If MaxPocet < 2 Then Chyba = 1
MaxPocet = MaxPocet + 1
End If
If Worksheets(NazevOkruhu).Cells(Adr, .Value > "" Then
If MaxPocet < 3 Then Chyba = 1
MaxPocet = MaxPocet + 1
End If
If MaxPocet < 2 Then
Chyba = 1
End If

If Chyba = 1 Then
Sheets("Main").Select
Response = MsgBox("Zkontrolujte, prosím, soubor otázek: " + NazevOkruhu + "!" + Chr(13) + "Některé otázky májí chybně zadané odpovědí.")
Exit Function
End If

Randomize
Poradi = Int(999999 * Rnd)
Worksheets(NazevOkruhu).Cells(Adr, 9).Value = Poradi
Spravna = Int(MaxPocet * Rnd + 1)
Worksheets(NazevOkruhu).Cells(Adr, 10).Value = Spravna
Worksheets(NazevOkruhu).Cells(Adr, 11).Value = MaxPocet
Worksheets(NazevOkruhu).Cells(Adr, 9).Value = Poradi

J = J + 1
Worksheets("Temp").Cells(J, 1).Value = Poradi
Worksheets("Temp").Cells(J, 2).Value = I
End If
Next I

MyTemp = MySort()
For II = 1 To PocetOtazek
Adr2 = Worksheets("Temp").Cells(II, 2).Value + 3
Worksheets(NazevOkruhu).Cells(Adr2, 12).Value = 1
Next II
If J < PocetOtazek Then
Sheets("Main").Select
Response = MsgBox("Zkontrolujte, prosím, soubor otázek: " + NazevOkruhu + "!" + Chr(13) + "Počet otázek není postačující.")
Exit Function
End If
End Function
Function TiskOkruh(NazevOkruhu, CisloOkruhu)
Worksheets("Tisk1").Cells(Radek, 1).Value = "Okruh otázek: " + Format(Worksheets("Main").Cells(6 + 5 * CisloOkruhu, 3).Value)
Worksheets("Tisk1").Cells(Radek, 1).Font.Italic = True
Worksheets("Tisk1").Cells(Radek, 1).Font.Size = 12

Worksheets("Tisk2").Cells(Radek2, 1).Value = "Okruh otázek: " + Format(Worksheets("Main").Cells(6 + 5 * CisloOkruhu, 3).Value)
Worksheets("Tisk2").Cells(Radek2, 1).Font.Italic = True
Worksheets("Tisk2").Cells(Radek2, 1).Font.Size = 12

Radek = Radek + 2
Radek2 = Radek2 + 2
Radek3 = Radek3 + 1
For I = 1 To 500
Adr = I + 3
If Worksheets(NazevOkruhu).Cells(Adr, 12).Value = 1 Then
Worksheets("Tisk1").Cells(Radek, 1).Value = Format(Otazka) + ". " + Format(Trim(Worksheets(NazevOkruhu).Cells(Adr, 4).Value))
Worksheets("Tisk1").Cells(Radek, 1).Font.Size = 12
Worksheets("Tisk1").Cells(Radek, 1).Font.Bold = True

Worksheets("Tisk2").Cells(Radek, 1).Value = Format(Otazka) + ". " + Format(Trim(Worksheets(NazevOkruhu).Cells(Adr, 4).Value))
Worksheets("Tisk2").Cells(Radek2, 1).Font.Size = 12
Worksheets("Tisk2").Cells(Radek, 1).Font.Bold = True

Radek = Radek + 1
Radek2 = Radek2 + 1

MaxOd = Worksheets(NazevOkruhu).Cells(Adr, 11).Value
Spravne = Worksheets(NazevOkruhu).Cells(Adr, 10).Value

Odpov1 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 5).Value)
Odpov2 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 6).Value)
Odpov3 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 7).Value)
Odpov4 = Trim(Worksheets(NazevOkruhu).Cells(Adr, .Value)

If Spravne = 2 Then
Odpov1 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 6).Value)
Odpov2 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 5).Value)
End If

If Spravne = 3 Then
Odpov1 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 7).Value)
Odpov3 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 5).Value)
End If

If Spravne = 4 Then
Odpov1 = Trim(Worksheets(NazevOkruhu).Cells(Adr, .Value)
Odpov4 = Trim(Worksheets(NazevOkruhu).Cells(Adr, 5).Value)
End If

Worksheets("Tisk1").Cells(Radek, 1).Value = " a) " + Format(Odpov1)
Radek = Radek + 1
Worksheets("Tisk1").Cells(Radek, 1).Value = " b) " + Format(Odpov2)
Radek = Radek + 1

Worksheets("Tisk2").Cells(Radek2, 1).Value = " a) " + Format(Odpov1)
If Spravne = 1 Then Worksheets("Tisk2").Cells(Radek2, 1).Font.Color = RGB(0, 0, 255)
Radek2 = Radek2 + 1
Worksheets("Tisk2").Cells(Radek2, 1).Value = " b) " + Format(Odpov2)
If Spravne = 2 Then Worksheets("Tisk2").Cells(Radek2, 1).Font.Color = RGB(0, 0, 255)
Radek2 = Radek2 + 1

If MaxOd > 2 Then
Worksheets("Tisk1").Cells(Radek, 1).Value = " c) " + Format(Odpov3)
Radek = Radek + 1
Worksheets("Tisk2").Cells(Radek2, 1).Value = " c) " + Format(Odpov3)
If Spravne = 3 Then Worksheets("Tisk2").Cells(Radek2, 1).Font.Color = RGB(0, 0, 255)
Radek2 = Radek2 + 1
End If

If MaxOd > 3 Then
Worksheets("Tisk1").Cells(Radek, 1).Value = " d) " + Format(Odpov4)
Radek = Radek + 1
Worksheets("Tisk2").Cells(Radek2, 1).Value = " d) " + Format(Odpov4)
If Spravne = 4 Then Worksheets("Tisk2").Cells(Radek2, 1).Font.Color = RGB(0, 0, 255)
Radek2 = Radek2 + 1
End If

Radek = Radek + 1
Radek2 = Radek2 + 1

If Worksheets(NazevOkruhu).Cells(Adr, 13).Value > "" Then
Worksheets("Tisk1").Cells(Radek, 1).Value = Format(Worksheets(NazevOkruhu).Cells(Adr, 13).Value)
Radek = Radek + 2
Worksheets("Tisk2").Cells(Radek2, 1).Value = Format(Worksheets(NazevOkruhu).Cells(Adr, 13).Value)
Radek2 = Radek2 + 2
End If

If Spravne = 1 Then SpravneLetter = "a"
If Spravne = 2 Then SpravneLetter = "b"
If Spravne = 3 Then SpravneLetter = "c"
If Spravne = 4 Then SpravneLetter = "d"

If ((Otazka > 0) And (Otazka < 18)) Then
SloupecTisk = 1 + Spravne
RowTisk = 14 + Otazka
End If

If ((Otazka > 17) And (Otazka < 35)) Then
SloupecTisk = 6 + Spravne
RowTisk = 14 + Otazka - 17
End If

If (Otazka > 34) Then
SloupecTisk = 11 + Spravne
RowTisk = 14 + Otazka - 34
End If

Worksheets("Tisk4").Cells(RowTisk, SloupecTisk).Font.Bold = True
Worksheets("Tisk4").Cells(RowTisk, SloupecTisk).Interior.Color = RGB(255, 0, 0)

If (Otazka = 6) Then
Worksheets("Tisk1").HPageBreaks.Add Before:=Cells(Radek, 1)
Worksheets("Tisk2").HPageBreaks.Add Before:=Cells(Radek2, 1)
End If
If (Otazka = 13) Then
Worksheets("Tisk1").HPageBreaks.Add Before:=Cells(Radek, 1)
Worksheets("Tisk2").HPageBreaks.Add Before:=Cells(Radek2, 1)
End If
If (Otazka = 20) Then
Worksheets("Tisk1").HPageBreaks.Add Before:=Cells(Radek, 1)
Worksheets("Tisk2").HPageBreaks.Add Before:=Cells(Radek2, 1)
End If
If (Otazka = 27) Then
Worksheets("Tisk1").HPageBreaks.Add Before:=Cells(Radek, 1)
Worksheets("Tisk2").HPageBreaks.Add Before:=Cells(Radek2, 1)
End If
If (Otazka = 34) Then
Worksheets("Tisk1").HPageBreaks.Add Before:=Cells(Radek, 1)
Worksheets("Tisk2").HPageBreaks.Add Before:=Cells(Radek2, 1)
End If
If (Otazka = 41) Then
Worksheets("Tisk1").HPageBreaks.Add Before:=Cells(Radek, 1)
Worksheets("Tisk2").HPageBreaks.Add Before:=Cells(Radek2, 1)
End If
If (Otazka = 48) Then
Worksheets("Tisk1").HPageBreaks.Add Before:=Cells(Radek, 1)
Worksheets("Tisk2").HPageBreaks.Add Before:=Cells(Radek2, 1)
End If

Radek3 = Radek3 + 1
Otazka = Otazka + 1

End If
Next I
Radek = Radek + 1
Radek2 = Radek2 + 1
End Function

Sub newtest()

Sheets("Temp").Select

Dim NumberTest
Dim J
Prubezne = 0

Worksheets("Tisk1").Unprotect ("1234")
Worksheets("Tisk2").Unprotect ("1234")
Worksheets("Tisk3").Unprotect ("1234")
Worksheets("Tisk4").Unprotect ("1234")

Worksheets("Tisk1").ResetAllPageBreaks
Worksheets("Tisk2").ResetAllPageBreaks
Worksheets("Tisk3").ResetAllPageBreaks
Worksheets("Tisk4").ResetAllPageBreaks

Worksheets("Tisk1").Range("A2:F1000").ClearContents
Worksheets("Tisk1").Range("A2:F1000").ClearFormats
Worksheets("Tisk1").Columns(1).ColumnWidth = 100
Worksheets("Tisk1").Range("A2:F1000").Font.Bold = False
Worksheets("Tisk1").Range("A2:F1000").Font.Italic = False
Worksheets("Tisk1").Range("A2:F1000").Font.Color = RGB(0, 0, 0)
Worksheets("Tisk1").Range("A2:F1000").Font.Name = "Times New Roman"

Worksheets("Tisk2").Range("A2:F1000").ClearContents
Worksheets("Tisk2").Range("A2:F1000").ClearFormats
Worksheets("Tisk2").Columns(1).ColumnWidth = 100
Worksheets("Tisk2").Range("A2:F1000").Font.Bold = False
Worksheets("Tisk2").Range("A2:F1000").Font.Italic = False
Worksheets("Tisk2").Range("A2:F1000").Font.Color = RGB(0, 0, 0)
Worksheets("Tisk2").Range("A2:F1000").Font.Name = "Times New Roman"

NumberTest = Time + Date

PocetOtazek = Worksheets("Main").Cells(12, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh1", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(17, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh2", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(22, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh3", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(27, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh4", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(32, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh5", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(37, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh6", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(42, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh7", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(47, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh8", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(52, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh9", PocetOtazek)

PocetOtazek = Worksheets("Main").Cells(57, 3).Value
If PocetOtazek > 0 Then RetVal = Okruh("Okruh10", PocetOtazek)

Worksheets("Tisk1").Range("A2:C2").HorizontalAlignment = xlCenter
Worksheets("Tisk2").Range("A2:C2").HorizontalAlignment = xlCenter
Worksheets("Tisk1").Range("A3:C1000").HorizontalAlignment = xlLeft
Worksheets("Tisk2").Range("A3:C1000").HorizontalAlignment = xlLeft
Worksheets("Tisk1").Range("A3:C1000").VerticalAlignment = xlTop
Worksheets("Tisk2").Range("A3:C1000").VerticalAlignment = xlTop

Worksheets("Tisk1").Range("A2:C1000").Font.Size = 10
Worksheets("Tisk2").Range("A2:C1000").Font.Size = 10

Worksheets("Tisk1").Rows("2:1000").RowHeight = 15
Worksheets("Tisk2").Rows("2:1000").RowHeight = 15

Worksheets("Tisk1").Range("A2:F1000").WrapText = True
Worksheets("Tisk2").Range("A2:F1000").WrapText = True

Worksheets("Tisk1").Cells(2, 1).Value = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value)
Worksheets("Tisk1").Cells(2, 1).Font.Bold = True
Worksheets("Tisk1").Cells(2, 1).Font.Size = 22
Worksheets("Tisk1").Cells(4, 1).Value = Format(Worksheets("Main").Cells(4, 3).Value)
Worksheets("Tisk1").Cells(4, 1).Font.Bold = True
Worksheets("Tisk1").Cells(4, 1).Font.Size = 16

Worksheets("Tisk2").Cells(2, 1).Value = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value)
Worksheets("Tisk2").Cells(2, 1).Font.Bold = True
Worksheets("Tisk2").Cells(2, 1).Font.Size = 22
Worksheets("Tisk2").Cells(4, 1).Value = Format(Worksheets("Main").Cells(4, 3).Value)
Worksheets("Tisk2").Cells(4, 1).Font.Bold = True
Worksheets("Tisk2").Cells(4, 1).Font.Size = 16

Worksheets("Tisk3").Cells(3, 1).Value = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value)
Worksheets("Tisk4").Cells(3, 1).Value = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value)

Worksheets("Tisk4").Range("B15:D31").Font.Bold = False
Worksheets("Tisk4").Range("B15:D31").Interior.Color = RGB(255, 255, 255)

Worksheets("Tisk4").Range("G15:I31").Font.Bold = False
Worksheets("Tisk4").Range("G15:I31").Interior.Color = RGB(255, 255, 255)

Worksheets("Tisk4").Range("L15:N30").Font.Bold = False
Worksheets("Tisk4").Range("L15:N30").Interior.Color = RGB(255, 255, 255)

Radek = 6
Radek2 = 6
Radek3 = 12
Otazka = 1

PocetOtazek = Worksheets("Main").Cells(12, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh1", 1)

PocetOtazek = Worksheets("Main").Cells(17, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh2", 2)

PocetOtazek = Worksheets("Main").Cells(22, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh3", 3)

PocetOtazek = Worksheets("Main").Cells(27, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh4", 4)

PocetOtazek = Worksheets("Main").Cells(32, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh5", 5)

PocetOtazek = Worksheets("Main").Cells(37, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh6", 6)

PocetOtazek = Worksheets("Main").Cells(42, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh7", 7)

PocetOtazek = Worksheets("Main").Cells(47, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh8",

PocetOtazek = Worksheets("Main").Cells(52, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh9", 9)

PocetOtazek = Worksheets("Main").Cells(52, 3).Value
If PocetOtazek > 0 Then RetVal = TiskOkruh("Okruh10", 10)

Worksheets("Tisk1").Range("A2:F1000").Rows.AutoFit
Worksheets("Tisk2").Range("A2:F1000").Rows.AutoFit

Worksheets("Tisk1").Range("A2:F1000").VerticalAlignment = xlCenter
Worksheets("Tisk2").Range("A2:F1000").VerticalAlignment = xlCenter

With Worksheets("Tisk1").PageSetup
.CenterHeader = ""
.CenterFooter = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value) + " / Vygenerováno: " + Format(Worksheets("Main").Cells(5, 3).Value) + " / Stránka &P z &N"
End With
With Worksheets("Tisk2").PageSetup
.CenterHeader = ""
.CenterFooter = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value) + " / Vygenerováno: " + Format(Worksheets("Main").Cells(5, 3).Value) + " / Stránka &P z &N"
End With
With Worksheets("Tisk3").PageSetup
.CenterHeader = ""
.CenterFooter = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value) + " / Vygenerováno: " + Format(Worksheets("Main").Cells(5, 3).Value)
End With
With Worksheets("Tisk4").PageSetup
.CenterHeader = ""
.CenterFooter = "TEST č." + Format(Worksheets("Main").Cells(7, 3).Value) + " / Vygenerováno: " + Format(Worksheets("Main").Cells(5, 3).Value)
End With

Worksheets("Tisk1").Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True
Worksheets("Tisk2").Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True
Worksheets("Tisk3").Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True
Worksheets("Tisk4").Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True

Sheets("Main").Select
Response = MsgBox("Test byl vygenerován!" + Chr(13) + "Vytisknete listy: Tisk1, Tisk2, Tisk3 a Tisk4.")
End Sub

Bohužel sem nejde přiložit originální soubor. Děkuju za každou radu.
Honza

Editováno 14.2.2017 14:08

Odpovědět

14.2.2017 14:07

NouF

Člen

NouF:14.2.2017 14:26

Myslim že jsou portály, kde se řeší rovnou excel. Najdeš tu asi málo lidí co píšou VBA.

Nahoru Odpovědět

14.2.2017 14:26

Jan Novák

Člen

Jan Novák :14.2.2017 14:37

No vím, že sem chodí spousta schopných lidí. Třeba se podaří...

Nahoru Odpovědět

14.2.2017 14:37

Libor Šimo (libcosenior)

Tvůrce

Libor Šimo (libcosenior):14.2.2017 14:50

Zdá sa mi, že 255(6) znakov je horná hranica, ktorá sa zmestí do jednej bunky. Teda ak je znakov viac, treba reťazec rozdeliť na dve čast a vypísať ich do buniek pod seba.
Nechci však odo mňa, aby som ti upravil kód. Na to ozaj nemám čas.

Nahoru Odpovědět

14.2.2017 14:50

Aj tisícmíľová cesta musí začať jednoduchým krokom.

zitekv

Člen

zitekv:14.2.2017 22:15

Jaká je to verze Excelu? Dříve tam možná limit 255 znaků byl. Ale to je u starých verzí, teď už se tam vejde znaků mraky.
Zkus napsat text delší než 255 znaků do buňky a zkopírovat, zda se to přenese celé.
Bez celého souboru se to hledá tezko. Pod komentářem je odkaz na vkládání dlouhého zdrojáku. Ale možná bude lepší to vyřešit přes soukromé zprávy.

Nahoru Odpovědět

14.2.2017 22:15

JK CZ

Člen

JK CZ:15.2.2017 14:11

Je to zpusobeno funkci Format, ktera ho zkrati.
Vymazal bych vsude Format, kde neni potreba.

'Napr:'
Worksheets("Tisk1").Cells(Radek, 1).Value = Format(Otazka) + ". " + Format(Trim(Worksheets(NazevOkruhu).Cells(Adr, 4).Value))

'Nahradit:'
Worksheets("Tisk1").Cells(Radek, 1).Value = Otazka & ". " & Trim(Worksheets(NazevOkruhu).Cells(Adr, 4).Value)

A mohlo by to fugovat...

Nahoru Odpovědět

15.2.2017 14:11

JK CZ

Člen

JK CZ:15.2.2017 19:50

Je to zpusobeno funkci Format, ktera ho zkrati.
Vymazal bych vsude Format, kde neni potreba.

'Napr:'
Worksheets("Tisk1").Cells(Radek, 1).Value = Format(Otazka) + ". " + Format(Trim(Worksheets(NazevOkruhu).Cells(Adr, 4).Value))

'Nahradit:'
Worksheets("Tisk1").Cells(Radek, 1).Value = Otazka & ". " & Trim(Worksheets(NazevOkruhu).Cells(Adr, 4).Value)

A mohlo by to fugovat...

Akceptované řešení
+20 Zkušeností
+2,50 Kč

Nahoru Odpovědět

15.2.2017 19:50

Jan Novák

Člen

Jan Novák :15.2.2017 23:52

Děkuji za pomoc a správné řešení. A děkuji i @zitekv za ochotu a podporu přes SZ.

Nahoru Odpovědět

15.2.2017 23:52