po delší době se opět hlásim s nějakými problémy. Rozhodl jsem se předělat funkci na makro a mám pár dotazů. Jedná se o veřejné makro, které zpracovává vstupní data přes dialogové okno userform.
userform vypadá takto:
kódy ke tlačítkům:
Kód: Vybrat vše
Private Sub buttOK_Click()
Dim mt1() As Variant
Dim mt2() As Variant
Dim hodnota As Variant
'testuje zda jsou zadane hodnoty matic
If RE_matice1 = "" Or RE_matice2 = "" Then
MsgBox ("Musite vybrat hodnoty matic.")
Exit Sub
End If
'naplnění proměnných daty
mt1 = Range(RE_matice1).Value
mt2 = Range(RE_matice2).Value
'ošetření proti zadávání nečíselných hodnot a prázdných buněk
For Each hodnota In mt1
If IsNumeric(hodnota) = False Or IsEmpty(hodnota) Then
MsgBox ("Některé z hodnot nejsou číselné nebo jsou prázdné.")
Exit Sub
End If
Next hodnota
For Each hodnota In mt2
If IsNumeric(hodnota) = False Or IsEmpty(hodnota) Then
MsgBox ("Některé z hodnot nejsou číselné nebo jsou prázdné.")
Exit Sub
End If
Next hodnota
' kontrola zda jsou rozměry obou matic shodné
If UBound(mt1) = UBound(mt2) And UBound(mt1, 2) = UBound(mt2, 2) Then
Call NovyList
Call SoucetM(mt1, mt2)
Else
MsgBox ("Obě matice musí mít stejné rozměry!")
Exit Sub
End If
Unload UserForm1
End Sub
'pro tlačítko storno
Private Sub buttStorno_Click()
Unload UserForm1
End Submodul1:
Kód: Vybrat vše
Sub SoucetMatic()
UserForm1.Show
End Sub
' vytvoří nový list s řešením
Sub NovyList()
Dim newSheet As Worksheet
i = 1
Set newSheet = Sheets.Add(after:=ActiveSheet, Count:=1)
On Error GoTo chyba
newSheet.Name = "Řešení " & Str(i)
i = i + 1
Exit Sub
chyba:
i = i + 1
Resume
End Sub
Function ScitaniM(mt1() As Variant, mt2() As Variant) As Variant()
Dim r As Integer, c As Integer
Dim vyslPole() As Variant
' redefinice výsledného pole podle rozměrů vstupních matic
ReDim vyslPole(LBound(mt1) To UBound(mt1), LBound(mt1, 2) To UBound(mt1, 2))
If UBound(mt1) = 1 And UBound(mt2) = 1 Then
vyslPole(r) = mt1(r) + mt2(r)
Else
' cyklus na procházení řádků a sloupců
' a následné vložení součtu do výsledného pole
For r = LBound(mt1) To UBound(mt1)
For c = LBound(mt1, 2) To UBound(mt1, 2)
vyslPole(r, c) = mt1(r, c) + mt2(r, c)
Next c
Next r
ScitaniM = vyslPole()
End If
End Function
modul2:
Kód: Vybrat vše
Sub SoucetM(mt1() As Variant, mt2() As Variant)
'Deklarace proměnných
Dim vysledek As Variant
'Volání vybrané funkce
vysledek = ScitaniM(mt1, mt2)
'Formátování na novém listu řešení
Range("B2").Select
ActiveCell.FormulaR1C1 = "Součet matic"
With ActiveCell.Font
.FontStyle = "Tučné"
.Size = 11
End With
Range("B5").Select
ActiveCell.FormulaR1C1 = "matice 1"
With ActiveCell.Font
.FontStyle = "Tučné"
End With
Range("C5").Select
ActiveCell.FormulaR1C1 = "matice 2"
With ActiveCell.Font
.FontStyle = "Tučné"
End With
Range("D5").Select
ActiveCell.FormulaR1C1 = "součet"
With ActiveCell.Font
.FontStyle = "Tučné"
End With
'výpis výsledku v určené oblasti
Range("D6").Resize(3, 3).Value = vysledek
End Sub1. dotaz - mám tu makro na generování nového listu s řešením a potřeboval bych, aby list vkládal za poslední list v sešitu
Kód: Vybrat vše
' vytvoří nový list s řešením
Sub NovyList()
Dim newSheet As Worksheet
i = 1
Set newSheet = Sheets.Add(after:=ActiveSheet, Count:=1) /// tady nevim, jak to přepsat
On Error GoTo chyba
newSheet.Name = "Řešení " & Str(i)
i = i + 1
Exit Sub
chyba:
i = i + 1
Resume
End Sub2. dotaz - na nový list s řešením (modul2) bych potřeboval vygenerovat i počítané matice (zadání), aby na výsledném listu s řešením bylo zadání + výsledek
Kód: Vybrat vše
'výpis výsledku v určené oblasti
Range("D6").Resize(3, 3).Value = vysledekJe to možná všechno trochu zmatené, ale jsem začátečník, tak bych prosil o trochu shovívavosti :)
