Diskuze: Nefunkční makro - "error time 445" na Excel 2016

Naučíme tě pracovat na home-office.

Zjistit více...

V předchozím kvízu, Test znalostí C# .NET online, jsme si ověřili nabyté zkušenosti z kurzu.

Aktivity

Milan Janoušek

Člen

Milan Janoušek:7.6.2018 11:31

@hoj.
Spouštím makro v Excel 2016 a hlásí to "error time 445". V Excel 2003 funguje. Může mi kód někdo opravit abych bylo makro spustitelné v Ex2016.
Dík za pomoc.

Zkusil jsem: Kód:

Private Sub CommandButton1_Click()
posun = 5
Load BankaOffLine
BankaOffLine.Show
End Sub

Private Sub CommandButton5_Click()
' založení nového listu
ActiveSheet.Range("a6").Select
ActiveSheet.Unprotect
posun = 5
vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count - posun
ActiveSheet.Protect
rozsah = "a6:m" & vet + 30
poclist = Sheets.Count
Sheets(1).Copy Before:=Sheets(poclist)
ActiveSheet.Range("a6").Select
ActiveSheet.Unprotect
' ActiveSheet.Name = "Ucet" & poclist
ActiveSheet.Range(rozsah).Select
Selection.EntireRow.Delete
Selection.Locked = True
ActiveSheet.Range("L3:l5").Select
Selection.ClearContents
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveSheet.Range("a6").Select
End Sub

Private Sub CommandButton4_Click()
' odemknutí / zamknutí vyplněných řádků a 5 prázdných k tomu
ActiveSheet.Range("a6").Select
ActiveSheet.Unprotect
vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count
If CommandButton4.Caption = "Zamknout list" Then
rozsah = "a6:z" & vet + 5 + volrad
ActiveSheet.Range(rozsah).Select
Selection.Locked = True
CommandButton4.Caption = "Odemknout list"
Else
rozsah = "a6:z" & vet + 5
ActiveSheet.Range(rozsah).Select
Selection.Locked = False
' Selection.FormulaHidden = False
CommandButton4.Caption = "Zamknout list"
End If
ActiveSheet.Range("a6").Select
ActiveSheet.Protect
End Sub

Private Sub CommandButton3_Click()
' Vymazat formulář
volrad = 10
posun = 5
co = MsgBox("Vymazat vše?", vbYesNo + vbDefaultButton2)
ActiveSheet.Range("a6").Select
ActiveSheet.Unprotect
vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count - posun
If co = vbYes Then
rozsah = "a6:m" & vet + 30
ActiveSheet.Range(rozsah).Select
Selection.EntireRow.Delete
' ElseIf co = vbNo Then
' For i = vet To 1 Step -1
' If UCase(ActiveCell(i, 1)) = "P" Then
' rozsah = "a" & i + posun
' ActiveSheet.Range(rozsah).Select
' Selection.EntireRow.Delete
' vet = vet - 1
' End If
' ActiveSheet.Range("a6").Select
' Next i
' If vet > 0 Then
' VV = vet + volrad
' VP = VV + posun
' rozsah = "e" & VP
' Range(rozsah).Select
' vzorec = "=COUNT(e6:e" & VP - 1 & " )"
' Range(rozsah).Value = vzorec
' rozsah = "e" & VP + 1
' Range(rozsah).Select
' vzorec = "=SUM(e6:e" & VP - 1 & " )"
' Range(rozsah).Value = vzorec
' End If
End If
ActiveSheet.Protect
ActiveSheet.Range("a6").Select
End Sub

Private Sub CommandButton2_Click()
' výstup do BEST
' Sheets("Opis").Visible = False
Dim ud, ucdb, stucdb As String
volrad = 10
posun = 5
dtspl = Date
for3 = "yyyymmdd"
mes = Month(Date)
rok = Right(Year(Date), 2)
den = Day(Date)
prvlist = ActiveSheet.Name
li = ActiveSheet.Index
ActiveSheet.Range("a6").Select
ActiveSheet.Unprotect
' výběry
' Load vyberform
' vyberform.Show
co = MsgBox("Jen tento list?", vbYesNo + vbDefaultButton2, "Tento list")
If co = vbYes Then
vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count - posun
If vet = 0 Then
xx = MsgBox("Na tomto listu nejsou žádné přikazy", vbOK)
Exit Sub
End If
jmli = prvlist
Else
jmli = ""
End If
' co = MsgBox("Omezit datum splatnosti?", vbYesNo + vbDefaultButton2)
' If co = vbYes Then
' dtspl = Format(InputBox("Do jakého data zaplatit vše?", "Omezení data splatnosti", dtspl), for3)
' dt = Format(dtspl, "dd.mm.yyyy")
' End If
' umístění souborů
cesta = ActiveSheet.Range("L3").Value
If Trim(cesta) = "" Then
cesta = CurDir
Else
Set fs = Application.FileSearch
With fs
.LookIn = cesta
.Filename = ".IKM"
If .Execute > 0 Then
ChDir cesta
Else
cesta = CurDir
End If
End With
End If
' určení jména a cesty
soub = "prikaz_KB_" & rok & " " & Right(" " & mes, 2) & " " & Right(" " & den, 2) & "_faktury" & ".IKM"
macesta = Application.GetSaveAsFilename(soub, fileFilter:="Formát BEST (.ikm), *.ikm")
ActiveSheet.Range("L3").Value = CurDir
If macesta <> False Then
' kontrola zda již neexistuje
co = vbYes
cesta = Left(macesta, InStrRev1((macesta), "\"))
' Set fs = Application.FileSearch
' With fs
' .LookIn = cesta
' .Filename = soub
' If .Execute > 0 Then
' co = MsgBox("Dnes jste již jeden soubor vytvořil. Přepsat?", vbYesNo)
' End If
' End With
' přepsat ANO
If co = vbYes Then
koso = 0 ' kontrolní součet
co = 0 ' počet chyb
povet = 0 ' počet vět do výstupního souboru
pcd = ActiveSheet.Range("L1").Value
Open macesta For Output As #1 ' Otevře soubor pro zápis.
Call HlaPa(1, 0, 0)
dt = Format(Year(Date)) & Right("0" & Format(Month(Date)), 2) & Right("0" & Format(Day(Date)), 2)
Dim mySheet As Worksheet
For Each mySheet In Worksheets
If mySheet.Name = "Opis" Then
Exit For
End If
If jmli = "" Then
mySheet.Select
End If
ActiveSheet.Range("a6").Select
ActiveSheet.Unprotect
vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count - posun
If vet = 0 Then Exit For
rud = "L4"
If Not KontUct(ActiveSheet.Range(rud).Value) Then
ActiveSheet.Range(rud).Select
co = co + 1
End If
UctDbt = Uctc
ucdb = UctDbt
KBD = "0100"
For i = 1 To vet
j = 2
UI = ActiveCell(i, j)
If Not KontUI(UI) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
Exit For
End If
UI = IIf(UI = "UHR", "0", "1")
j = j + 1
If Not KontUct(ActiveCell(i, j)) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
End If
UctKredit = Uctc
uckr = UctKredit
j = j + 1
KBK = Right("0000" & Format(ActiveCell(i, j)), 4)
If Not KontKB(KBK) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
End If
If UctDbt = UctKredit And KBD = KBK Then
xx = MsgBox("Nesmí být stejné účty debet a kredit", vbExclamation, "VAROVÁNÍ")
ActiveCell.Offset(i - 1, j - 3).Range("a1").Select
co = co + 1
Exit For
End If
j = j + 1
Castka = Int(ActiveCell(i, j) * 100)
koso = koso + Castka
If Not KontCastka(Castka) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
End If
Castka = Right(String(15, "0") & Format(Castka), 15)
j = j + 1
Splatnost = ActiveCell(i, j)
dd = ""
mm = ""
rr = ""
k = 1
zn = Mid(Splatnost, k, 1)
Do Until zn < "0" Or zn > "9"
dd = dd + zn
k = k + 1
zn = Mid(Splatnost, k, 1)
Loop
k = k + 1
zn = Mid(Splatnost, k, 1)
Do Until zn < "0" Or zn > "9"
mm = mm + zn
k = k + 1
zn = Mid(Splatnost, k, 1)
Loop
k = k + 1
zn = Mid(Splatnost, k, 1)
Do Until zn < "0" Or zn > "9"
rr = rr + zn
k = k + 1
zn = Mid(Splatnost, k, 1)
Loop
r = Val(rr)
If r < 1000 Then
r = r + 2000
End If
m = Val(mm)
d = Val(dd)
If m = 2 Then
If r Mod 4 = 0 Then
kd = 29
Else
kd = 28
End If
Else
If m > 7 Then
kd = 31 - m Mod 2
Else
kd = 30 + m Mod 2
End If
End If
spl = Right("0000" & r, 4) + Right("0" & mm, 2) + Right("0" & dd, 2)
spl1 = Right("0" & dd, 2) + "." + Right("0" & mm, 2) + "." + Right("0000" & r, 4)
If d < 1 Or d > kd Or m > 12 Or m < 1 Then
xx = MsgBox("Nesprávný datum", vbExclamation, "VAROVÁNÍ")
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
Else
If Not KontSplat(spl1) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
End If
End If
j = j + 1
VS = Right(String(10, "0") & Trim(ActiveCell(i, j)), 10)
If Not KontVS(VS) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
End If
j = j + 1
KS = Right(String(10, "0") & Trim(ActiveCell(i, j)), 10)
If Not KontKS(KS) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
End If
j = j + 1
SS = Right(String(10, "0") & Trim(ActiveCell(i, j)), 10)
If Not KontSS(SS) Then
ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
co = co + 1
Exit For
End If
j = j + 1
Zpravapr = Left(ActiveCell(i, j) & Space(30), 30)
j = j + 1
zpravapa = Left(ActiveCell(i, j) & Space(30), 30)
' If spl <= dtspl Or dtspl = "" Then
If pcd < 999 Then
pcd = pcd + 1
Else
pcd = 0
End If
Print #1, "01"; Right("00000" & Format(li * 1000 + pcd), 5); dt; spl; "CZK"; Castka; UI; "0000"; KS; Space(143); KBD; ucdb; VS; SS; Zpravapr; " "; KBK; uckr; VS; SS; zpravapa; Space(9)
povet = povet + 1
' ActiveCell(i, 1) = "P"
' Else
' ActiveCell(i, 1) = ""
' End If
Next i
ActiveSheet.Range("L1").Value = pcd
If co = 0 Then
VV = vet + volrad
VP = VV + posun
' With ActiveSheet
' rozsah = "e" & VP
' vzorec = "=COUNTIF(a6:a" & VP - 1 & ", ""P"" )"
' .Range(rozsah).Value = vzorec
' rozsah = "e" & VP + 1
' vzorec = "=SUMIF(a6:a" & VP - 1 & ", ""P"" , e6:e" & VP - 1 & " )"
' .Range(rozsah).Value = vzorec
' End With
' CommandButton4.Caption = "Zamknout list"
' CommandButton4_Click
Else
Exit For
End If
If jmli <> "" Then
Exit For
End If
Next mySheet
Call HlaPa(2, povet, koso)
Close #1 ' Uzavře soubor.
' Kontrola počtu vět
If co = 0 Then
If povet > 0 Then
' Sheets("Opis").Visible = True
Sheets("Opis").Activate
ActiveSheet.Unprotect
ActiveSheet.Range("a6").Select
vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count + posun + volrad
rozsah = "a6:m" & vet + 30
ActiveSheet.Range(rozsah).Select
Selection.EntireRow.Delete
ActiveSheet.Range("a6").Select
i = 0
stucdb = "99999"
zavet = 0
Open macesta For Input As #1 ' Otevře soubor pro čtení
Do While Not EOF(1) ' Loop until end of file.
Line Input #1, textline ' Read line into variable.
kd = Left(textline, 2)
If kd = "01" Then
i = i + 1
j = 2
kd = Mid(textline, 200, 4)
ucdb = Mid(textline, 204, 16)
If stucdb <> ucdb Then
ActiveCell(i, j) = " "
i = i + 1
ActiveCell(i, j + 1) = "Na vrub uctu: " & ucdb & " / " & kd
i = i + 1
ActiveCell(i, j) = " "
stucdb = ucdb
i = i + 1
End If
uh = IIf(Mid(textline, 42, 1) = "0", "UHR", "INK")
ActiveCell(i, j) = uh
j = j + 1
ud = Mid(textline, 277, 16) ' ucet příjemce
ActiveCell(i, j) = ud
j = j + 1
ud = Mid(textline, 273, 4) ' kod banky příjemce
ActiveCell(i, j) = ud
j = j + 1
ud = Mid(textline, 27, 15) ' částka
ActiveCell(i, j) = Val(ud) / 100
j = j + 1
rr = Mid(textline, 16, 4) ' splatnost rok
mm = Mid(textline, 20, 2) ' splatnost mes
dd = Mid(textline, 22, 2) ' splatnost den
ActiveCell(i, j) = dd & "." & mm & "." & rr
j = j + 1
ud = Mid(textline, 293, 10) ' variabilní symb
ActiveCell(i, j) = ud
j = j + 1
ud = Mid(textline, 47, 10) ' konstantní symb
ActiveCell(i, j) = ud
j = j + 1
ud = Mid(textline, 303, 10) ' specifický symb
ActiveCell(i, j) = ud
j = j + 1
ud = Mid(textline, 240, 30) ' Zpráva pro příkazce
ActiveCell(i, j) = ud
j = j + 1
ud = Mid(textline, 313, 30) ' zpráva pro příjemce
ActiveCell(i, j) = ud
End If
zavet = zavet + 1
Loop
Close #1 ' Uzavře soubor.
VV = i + volrad
VP = VV + posun
rozsah = "b" & VP & ":e" & VP + 1
rrozsah = " " & VP & ":" & VP + 1
ActiveSheet.Range(rozsah).Select
Selection.Font.Bold = True
Selection.Font.Size = 11
Selection.HorizontalAlignment = xlLeft
ActiveSheet.Rows(rrozsah).RowHeight = 20
ActiveCell(1, 2) = "Počet příkazů:"
ActiveCell(2, 2) = "Celkem Kč:"
rozsah = "e" & VP
ActiveSheet.Range(rozsah).Select
Selection.NumberFormat = "0"
Selection.HorizontalAlignment = xlRight
vzorec = "=COUNT(e6:e" & VP - 1 & " )"
ActiveSheet.Range(rozsah).Value = vzorec
rozsah = "e" & VP + 1
ActiveSheet.Range(rozsah).Select
Selection.NumberFormat = "#,##0.00"
Selection.NumberFormat = for1
Selection.HorizontalAlignment = xlRight
vzorec = "=SUM(e6:e" & VP - 1 & " )"
ActiveSheet.Range(rozsah).Value = vzorec
ActiveSheet.Protect
If zavet = povet + 2 Then
xx = MsgBox("Soubor " & macesta & " byl úspěšně vytvořen." + Chr(13) + Chr(13) _
+ " přečteno příkazů " & povet & Chr(13) _
+ " zapsáno příkazů " & zavet - 2 & Chr(13) + Chr(13) _
+ "Soubor dávky nyní zašlete pomocí služby mojebanka do KB." + Chr(13) _
+ "Funkci pro načtení dávky najdete v aplikaci mojebanka pod položkou" + Chr(13) _
+ "menu ""Dávkové příkazy"", pod odkazem ""Odeslání dávky do banky"". ", vbOKOnly)
xx = MsgBox("Přejete si opis na tiskárnu?", vbYesNo)
If xx = vbYes Then
' OpisBtn_Click
pocstran = Int(i - 5 / 45) + 1
rozsah = "b6:k" & i + posun + volrad + 2
ActiveSheet.PageSetup.PrintArea = rozsah
With ActiveSheet.PageSetup
.PrintTitleRows = "$3:$5"
.PrintTitleColumns = ""
.LeftHeader = "Dne &D"
.CenterHeader = "&""Arial CE,tučné""&16Opis platebních příkazů do mojebanka&""Arial CE,obyčejné""" & Chr(10) & ""
.RightHeader = "Strana &P"
.LeftMargin = Application.InchesToPoints(0.78740157480315)
.RightMargin = Application.InchesToPoints(0.78740157480315)
.TopMargin = Application.InchesToPoints(0.984251968503937)
.BottomMargin = Application.InchesToPoints(0.984251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
' .Orientation = xlPortrait
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = pocstran
End With
' ActiveWindow.SelectedSheets.PrintOut Copies:=1
ActiveWindow.SelectedSheets.PrintPreview
' Sheets("Opis").Select
' ActiveWindow.SelectedSheets.Visible = False
Sheets(prvlist).Activate
End If
Else
xx = MsgBox("Nesouhlasí počet vět ve výstupním souboru " & macesta & ". Bude smazán", vbOKOnly)
Kill (macesta)
End If
Else
xx = MsgBox("Soubor " & macesta & " se nevytvořil", vbOKOnly)
Kill (macesta)
End If
Else
xx = MsgBox("Byly nalezeny chyby v zadání příkazů", vbOKOnly)
Kill (macesta)
End If
End If
End If
End Sub

Function InStrRev1(ret As String, zn As String) As Integer
InStrRev1 = 0
l = Len(ret)
For i = l To 1 Step -1
ch = Mid(ret, i, 1)
If ch = zn Then
InStrRev1 = i
Exit For
End If
Next i
End Function

Function InStrRevL(ret As String, zn As String) As Integer
InStrRevL = 0
l = Len(ret)
For i = 1 To l
ch = Mid(ret, i, 1)
If ch = zn Then
InStrRevL = i
Exit For
End If
Next i
End Function

Function KontModulo(ucet As String) As Boolean
vah6 = "10 5 8 4 2 1"
vah10 = " 6 3 7 910 5 8 4 2 1"
delka = Len(ucet)
If delka = 6 Then
vahy = vah6
ElseIf delka = 10 Then
vahy = vah10
Else
vahy = vah6 + vah10
End If
cis = 0
For i = 1 To delka
zn = Mid(ucet, i, 1)
If zn < "0" Or zn > "9" Then
xx = MsgBox("Obsahuje nepovolený znak", vbExclamation, "VAROVÁNÍ")
cis = 9
Exit For
End If
cis = cis + Val(zn) * Val(Mid(vahy, 2 * i - 1, 2))
Next i
If cis Mod 11 = 0 Then
KontModulo = True
Else
xx = MsgBox("Není modulo 11.", vbExclamation, "VAROVÁNÍ")
KontModulo = False
End If
End Function

Private Sub HlaPa(co, poza, koso)
dt = Right(Format(Year(Date)), 2) & Right("0" & Format(Month(Date)), 2) & Right("0" & Format(Day(Date)), 2)
If co = 1 Then
Print #1, "HI"; String(9, "0"); dt; Space(334)
Else
Print #1, "TI"; String(9, "0"); dt; Right("000000" & Format(poza), 6); Right(String(18, "0") & Format(koso), 18); Space(310)
End If
End Sub

Function KontUct(ucet As String) As Boolean
delka = Len(ucet)
i = InStrRevL(ucet, "-")
If i > 0 Then
pruct = Left(ucet, i - 1)
Uct = Mid(ucet, i + 1)
i = InStrRevL Then
Uct = Left(Uct, i - 1) & Mid(Uct, i + 1)
End If
End If
Else
If delka > 10 Then
pruct = Left(ucet, delka - 10)
Uct = Right(ucet, 10)
Else
Uct = ucet
End If
End If
pruct = Right("000000" & pruct, 6)
Uct = Right("0000000000" & Uct, 10)
Uctc = pruct & Uct
If delka > 17 Or delka < 2 Then
KontUct = False
xx = MsgBox("Moc dlouhé číslo účtu", vbExclamation, "VAROVÁNÍ")
ElseIf Not KontModulo Then
KontUct = False
ElseIf Not KontModulo Then
KontUct = False
ElseIf Not KontModulo Then
KontUct = False
ElseIf Val(ucet) = 0 Then
xx = MsgBox("Bankovní spojení je povinný údaj", vbExclamation, "VAROVÁNÍ")
KontUct = False
Else
KontUct = True
End If
End Function

Function KontKB(kodba) As Boolean
delka = Len(kodba)
hlaska = "Kod banky je povinný údaj"
If delka > 4 Then
KontKB = False
xx = MsgBox("Moc dlouhý kod banky", vbExclamation, "VAROVÁNÍ")
ElseIf Val(kodba) = 0 Then
xx = MsgBox(hlaska, vbExclamation, "VAROVÁNÍ")
KontKB = False
Else
KontKB = povzn(kodba, hlaska)
End If
End Function

Function KontCastka(Castka) As Boolean
delka = Len(Castka)
If delka > 15 Then
KontCastka = False
xx = MsgBox("Moc dlouhá částka", vbExclamation, "VAROVÁNÍ")
ElseIf Val(Castka) <= 0 Then
xx = MsgBox("Částka musí být větší než 0", vbExclamation, "VAROVÁNÍ")
KontCastka = False
Else
KontCastka = True
End If
End Function

Function KontSplat(splat) As Boolean
If splat = "" Then
xx = MsgBox("Nezadáno žádné datum", vbExclamation, "VAROVÁNÍ")
KontSplat = False
ElseIf dtpor(splat) < Format(Date, for3) Then
xx = MsgBox("Zadané datum již nastalo", vbExclamation, "VAROVÁNÍ")
KontSplat = False
ElseIf dtpor(splat) > Format(Date + 364, for3) Then
xx = MsgBox("Zadané datum nesmí být více než rok dopředu", vbExclamation, "VAROVÁNÍ")
KontSplat = False
Else
KontSplat = True
End If
End Function

Function KontKS(KS) As Boolean
delka = Len(KS)
hlaska = "Chyba zadání konstantního symbolu, konstantní symbol je povinný znak"
If Val(KS) = 0 Then
KontKS = False
xx = MsgBox(hlaska, vbExclamation, "VAROVÁNÍ")
ElseIf delka > 10 Then
KontKS = False
xx = MsgBox("Moc dlouhý konstantní symbol", vbExclamation, "VAROVÁNÍ")
Else
KontKS = povzn(KS, hlaska)
zn = Right(KS, 1)
If zn = "0" Or zn = "1" Or zn = "3" Or zn = "5" Or zn = "9" Then
KontKS = False
xx = MsgBox(hlaska, vbExclamation, "VAROVÁNÍ")
ElseIf KS = "0178" Or KS = "1178" Or KS = "2178" Or KS = "3178" Then
KontKS = False
xx = MsgBox(hlaska, vbExclamation, "VAROVÁNÍ")
End If
End If
End Function

Function KontVS(VS) As Boolean
delka = Len(VS)
If delka > 10 Then
KontVS = False
xx = MsgBox("Moc dlouhý variabilní symbol", vbExclamation, "VAROVÁNÍ")
Else
hlaska = "Chyba zadání variabilního symbolu"
KontVS = povzn(VS, hlaska)
End If
End Function

Function KontSS(SS) As Boolean
hlaska = "Chyba zadání specifického symbolu"
KontSS = povzn(SS, hlaska)
End Function

Function KontUI(UI) As Boolean
If Not (UI = "UHR" Or UI = "INK") Then
KontUI = False
xx = MsgBox("Druh platby je jen UHR - Úhrada" + Chr(13) _
+ " INK - Inkaso", vbExclamation, "VAROVÁNÍ")
Else
KontUI = True
End If
End Function

Function dtpor(dt) As String
dtpor = Right(dt, 4) & Mid(dt, 4, 2) & Left(dt, 2)
End Function

Function povzn(cis, udaj) As Boolean
povzn = True
dl = Len(cis)
For i = 1 To dl
zn = Mid(cis, i, 1)
If zn < "0" Or zn > "9" Then
xx = MsgBox(udaj, vbExclamation, "VAROVÁNÍ")
povzn = False
Exit For
End If
Next i
End Function

Private Sub CommandButton6_Click()
arch = ActiveSheet.Range("L5").Value
If Trim(arch) = "" Then
arch = CurDir
Else
Set fs = Application.FileSearch
With fs
.LookIn = arch
.Filename = NUL
If .Execute > 0 Then
ChDir arch
Else
arch = CurDir
End If
End With
End If
' určení jména a cesty
mes = Month(Date)
rok = Year(Date)
den = Day(Date)
soub = "AR" & Right(rok, 2) & Right("0" & mes, 2) & Right("0" & den, 2) & ".XLS"
macesta = Application.GetSaveAsFilename(soub, fileFilter:="Archiv (*.xls), *.xls")
ActiveSheet.Range("L5").Select
ActiveSheet.Unprotect
ActiveSheet.Range("L5").Value = CurDir
If macesta <> False Then
' kontrola zda již neexistuje
co = vbYes
ActiveSheet.Protect
ActiveSheet.Range("a6").Select
cesta = Left(macesta, InStrRev1((macesta), "\"))
soub = Mid(macesta, InStrRev1((macesta), "\") + 1)
Set fs = Application.FileSearch
With fs
.LookIn = cesta
.Filename = soub
If .Execute > 0 Then
co = MsgBox("Dnes jste již jeden soubor vytvořil. Přepsat?", vbYesNo)
If co = vbYes Then
Kill (macesta)
End If
End If
End With
If co = vbYes Then
ActiveWorkbook.SaveAs Filename:=macesta, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.Quit
End If
End If
End Sub

Chci docílit: Chci generovat dávkový příkaz do banky . IKM

Odpovědět

7.6.2018 11:31

Roman

Člen

Roman:7.6.2018 13:02

Vloz kod znovu a pouzij code!

Nahoru Odpovědět

7.6.2018 13:02

plelovsky

Člen

plelovsky:8.6.2018 11:01

http://lmgtfy.com/?…

https://www.mrexcel.com/…r-445-a.html

Nahoru Odpovědět

8.6.2018 11:01

Tarantula222

Člen

Tarantula222:9.6.2018 0:08

V makre používaš metódu "FileSearch" ktorá už v novších verziách exclu neexistuje.
Upravil som ti to na funkciu Dir, asi to bude ešte chcieť doladiť. Vyskúšaj a daj vedieť.

Private Sub CommandButton6_Click()
    arch = ActiveSheet.Range("L5").Value
    If Trim(arch) = "" Then
        arch = CurDir
    Else
        If Not Len(Dir(arch & "\" & NUL)) = 0 Then  'tato časť bude chcieť pravdepodobne upraviť. Neviem čo je v premennej NUL
            ChDir arch
        Else
            arch = CurDir
        End If
    End If

    ' určení jména a cesty
    mes = Month(Date)
    rok = Year(Date)
    Den = Day(Date)
    soub = "AR" & Right(rok, 2) & Right("0" & mes, 2) & Right("0" & Den, 2) & ".XLS"
    macesta = Application.GetSaveAsFilename(soub, fileFilter:="Archiv (*.xls), *.xls")
    ActiveSheet.Range("L5").Select
    ActiveSheet.Unprotect
    ActiveSheet.Range("L5").Value = CurDir

    If macesta <> False Then
        ' kontrola zda již neexistuje
        co = vbYes
        ActiveSheet.Protect
        ActiveSheet.Range("a6").Select

        If Not Len(Dir(macesta)) = 0 Then
            co = MsgBox("Dnes jste již jeden soubor vytvořil. Přepsat?", vbYesNo)
            If co = vbYes Then
                Kill (macesta)
            End If
        End If

        If co = vbYes Then
            ActiveWorkbook.SaveAs Filename:=macesta, _
            FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
            Application.Quit
        End If
    End If
End Sub

Nahoru Odpovědět

9.6.2018 0:08

Chceš realizovat své sny? Probuď se!

Milan Janoušek

Člen

Milan Janoušek:9.6.2018 19:20

Funguje, jsi machr. Můžu Tě ještě poprosit o úpravu všech zbývajících kódů od 1 - 5. Ta 6estka je super šlape.
Dík moooc a C@uki.

Nahoru Odpovědět

9.6.2018 19:20

Tarantula222

Člen

Tarantula222:9.6.2018 22:48

Chyba bola ešte v dvojke, to som si včera nevšimol. Máš ju opravenú, vyskúšaj.

Private Sub CommandButton2_Click()
        ' výstup do BEST
        ' Sheets("Opis").Visible = False
        Dim ud, ucdb, stucdb As String
        volrad = 10
        posun = 5
        dtspl = Date
        for3 = "yyyymmdd"
        mes = Month(Date)
        rok = Right(Year(Date), 2)
        den = Day(Date)
        prvlist = ActiveSheet.Name
        li = ActiveSheet.Index
        ActiveSheet.Range("a6").Select
        ActiveSheet.Unprotect
                ' výběry
                ' Load vyberform
                ' vyberform.Show

                co = MsgBox("Jen tento list?", vbYesNo + vbDefaultButton2, "Tento list")
                If co = vbYes Then
                        vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count - posun
                        If vet = 0 Then
                                xx = MsgBox("Na tomto listu nejsou žádné přikazy", vbOK)
                                Exit Sub
                        End If
                        jmli = prvlist
                Else
                        jmli = ""
                End If

                ' co = MsgBox("Omezit datum splatnosti?", vbYesNo + vbDefaultButton2)
                ' If co = vbYes Then
                ' dtspl = Format(InputBox("Do jakého data zaplatit vše?", "Omezení data splatnosti", dtspl), for3)
                ' dt = Format(dtspl, "dd.mm.yyyy")
                ' End If

                ' umístění souborů
                cesta = ActiveSheet.Range("L3").Value
                If Trim(cesta) = "" Then
                        cesta = CurDir
                Else
                        If Not Len(Dir(cesta & "\*.IKM")) = 0 Then
                                ChDir cesta
                        Else
                                cesta = CurDir
                        End If
                End If

                ' určení jména a cesty
                soub = "prikaz_KB_" & rok & " " & Right(" " & mes, 2) & " " & Right(" " & den, 2) & "_faktury" & ".IKM"
                macesta = Application.GetSaveAsFilename(soub, fileFilter:="Formát BEST (.ikm), *.ikm")
                ActiveSheet.Range("L3").Value = CurDir

                If macesta <> False Then
                        ' kontrola zda již neexistuje
                        co = vbYes
                        cesta = Left(macesta, InStrRev1((macesta), "\"))

                        'If Not Len(Dir(macesta)) = 0 Then
                        '       co = MsgBox("Dnes jste již jeden soubor vytvořil. Přepsat?", vbYesNo)
                        'End If

                        ' přepsat ANO
                        If co = vbYes Then
                        koso = 0 ' kontrolní součet
                        co = 0 ' počet chyb
                        povet = 0 ' počet vět do výstupního souboru
                        pcd = ActiveSheet.Range("L1").Value
                        Open macesta For Output As #1 ' Otevře soubor pro zápis.
                        Call HlaPa(1, 0, 0)
                        dt = Format(Year(Date)) & Right("0" & Format(Month(Date)), 2) & Right("0" & Format(Day(Date)), 2)

                        Dim mySheet As Worksheet

                        For Each mySheet In Worksheets
                                If mySheet.Name = "Opis" Then
                                        Exit For
                                End If

                                If jmli = "" Then
                                        mySheet.Select
                                End If

                                ActiveSheet.Range("a6").Select
                                ActiveSheet.Unprotect
                                vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count - posun

                                If vet = 0 Then Exit For
                                rud = "L4"
                                If Not KontUct(ActiveSheet.Range(rud).Value) Then
                                        ActiveSheet.Range(rud).Select
                                        co = co + 1
                                End If

                                UctDbt = Uctc
                                ucdb = UctDbt
                                KBD = "0100"
                                For i = 1 To vet
                                        j = 2
                                        UI = ActiveCell(i, j)
                                        If Not KontUI(UI) Then
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                Exit For
                                        End If
                                        UI = IIf(UI = "UHR", "0", "1")
                                        j = j + 1
                                        If Not KontUct(ActiveCell(i, j)) Then
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        End If
                                        UctKredit = Uctc
                                        uckr = UctKredit
                                        j = j + 1
                                        KBK = Right("0000" & Format(ActiveCell(i, j)), 4)
                                        If Not KontKB(KBK) Then
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        End If
                                        If UctDbt = UctKredit And KBD = KBK Then
                                                xx = MsgBox("Nesmí být stejné účty debet a kredit", vbExclamation, "VAROVÁNÍ")
                                                ActiveCell.Offset(i - 1, j - 3).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        End If
                                        j = j + 1
                                        Castka = Int(ActiveCell(i, j) * 100)
                                        koso = koso + Castka
                                        If Not KontCastka(Castka) Then
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        End If
                                        Castka = Right(String(15, "0") & Format(Castka), 15)
                                        j = j + 1
                                        Splatnost = ActiveCell(i, j)
                                        dd = ""
                                        mm = ""
                                        rr = ""
                                        k = 1
                                        zn = Mid(Splatnost, k, 1)
                                        Do Until zn < "0" Or zn > "9"
                                                dd = dd + zn
                                                k = k + 1
                                                zn = Mid(Splatnost, k, 1)
                                        Loop
                                        k = k + 1
                                        zn = Mid(Splatnost, k, 1)
                                        Do Until zn < "0" Or zn > "9"
                                                mm = mm + zn
                                                k = k + 1
                                                zn = Mid(Splatnost, k, 1)
                                        Loop
                                        k = k + 1
                                        zn = Mid(Splatnost, k, 1)
                                        Do Until zn < "0" Or zn > "9"
                                                rr = rr + zn
                                                k = k + 1
                                                zn = Mid(Splatnost, k, 1)
                                        Loop
                                        r = Val(rr)
                                        If r < 1000 Then
                                                r = r + 2000
                                        End If
                                        m = Val(mm)
                                        d = Val(dd)
                                        If m = 2 Then
                                                If r Mod 4 = 0 Then
                                                        kd = 29
                                                Else
                                                        kd = 28
                                                End If
                                        Else
                                                If m > 7 Then
                                                        kd = 31 - m Mod 2
                                                Else
                                                        kd = 30 + m Mod 2
                                                End If
                                        End If
                                        spl = Right("0000" & r, 4) + Right("0" & mm, 2) + Right("0" & dd, 2)
                                        spl1 = Right("0" & dd, 2) + "." + Right("0" & mm, 2) + "." + Right("0000" & r, 4)
                                        If d < 1 Or d > kd Or m > 12 Or m < 1 Then
                                                xx = MsgBox("Nesprávný datum", vbExclamation, "VAROVÁNÍ")
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        Else
                                                If Not KontSplat(spl1) Then
                                                        ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                        co = co + 1
                                                        Exit For
                                                End If
                                        End If
                                        j = j + 1
                                        VS = Right(String(10, "0") & Trim(ActiveCell(i, j)), 10)
                                        If Not KontVS(VS) Then
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        End If
                                        j = j + 1
                                        KS = Right(String(10, "0") & Trim(ActiveCell(i, j)), 10)
                                        If Not KontKS(KS) Then
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        End If
                                        j = j + 1
                                        SS = Right(String(10, "0") & Trim(ActiveCell(i, j)), 10)
                                        If Not KontSS(SS) Then
                                                ActiveCell.Offset(i - 1, j - 1).Range("a1").Select
                                                co = co + 1
                                                Exit For
                                        End If
                                        j = j + 1
                                        Zpravapr = Left(ActiveCell(i, j) & Space(30), 30)
                                        j = j + 1
                                        zpravapa = Left(ActiveCell(i, j) & Space(30), 30)
                                        ' If spl <= dtspl Or dtspl = "" Then
                                        If pcd < 999 Then
                                                pcd = pcd + 1
                                        Else
                                                pcd = 0
                                        End If
                                        Print #1, "01"; Right("00000" & Format(li * 1000 + pcd), 5); dt; spl; "CZK"; Castka; UI; "0000"; KS; Space(143); KBD; ucdb; VS; SS; Zpravapr; " "; KBK; uckr; VS; SS; zpravapa; Space(9)
                                        povet = povet + 1
                                        ' ActiveCell(i, 1) = "P"
                                        ' Else
                                        ' ActiveCell(i, 1) = ""
                                        ' End If
                                Next i

                                ActiveSheet.Range("L1").Value = pcd
                                If co = 0 Then
                                        VV = vet + volrad
                                        VP = VV + posun
                                        ' With ActiveSheet
                                        ' rozsah = "e" & VP
                                        ' vzorec = "=COUNTIF(a6:a" & VP - 1 & ", ""P"" )"
                                        ' .Range(rozsah).Value = vzorec
                                        ' rozsah = "e" & VP + 1
                                        ' vzorec = "=SUMIF(a6:a" & VP - 1 & ", ""P"" , e6:e" & VP - 1 & " )"
                                        ' .Range(rozsah).Value = vzorec
                                        ' End With
                                        ' CommandButton4.Caption = "Zamknout list"
                                        ' CommandButton4_Click
                                Else
                                        Exit For
                                End If

                                If jmli <> "" Then
                                        Exit For
                                End If
                        Next mySheet

                        Call HlaPa(2, povet, koso)
                        Close #1 ' Uzavře soubor.
                        ' Kontrola počtu vět

                        If co = 0 Then
                                If povet > 0 Then
                                        ' Sheets("Opis").Visible = True
                                        Sheets("Opis").Activate
                                        ActiveSheet.Unprotect
                                        ActiveSheet.Range("a6").Select
                                        vet = ActiveSheet.Range("a1").CurrentRegion.Rows.Count + posun + volrad
                                        rozsah = "a6:m" & vet + 30
                                        ActiveSheet.Range(rozsah).Select
                                        Selection.EntireRow.Delete
                                        ActiveSheet.Range("a6").Select
                                        i = 0
                                        stucdb = "99999"
                                        zavet = 0
                                        Open macesta For Input As #1 ' Otevře soubor pro čtení

                                        Do While Not EOF(1) ' Loop until end of file.
                                                Line Input #1, textline ' Read line into variable.
                                                kd = Left(textline, 2)
                                                If kd = "01" Then
                                                        i = i + 1
                                                        j = 2
                                                        kd = Mid(textline, 200, 4)
                                                        ucdb = Mid(textline, 204, 16)

                                                        If stucdb <> ucdb Then
                                                                ActiveCell(i, j) = " "
                                                                i = i + 1
                                                                ActiveCell(i, j + 1) = "Na vrub uctu: " & ucdb & " / " & kd
                                                                i = i + 1
                                                                ActiveCell(i, j) = " "
                                                                stucdb = ucdb
                                                                i = i + 1
                                                        End If

                                                        uh = IIf(Mid(textline, 42, 1) = "0", "UHR", "INK")
                                                        ActiveCell(i, j) = uh
                                                        j = j + 1
                                                        ud = Mid(textline, 277, 16) ' ucet příjemce
                                                        ActiveCell(i, j) = ud
                                                        j = j + 1
                                                        ud = Mid(textline, 273, 4) ' kod banky příjemce
                                                        ActiveCell(i, j) = ud
                                                        j = j + 1
                                                        ud = Mid(textline, 27, 15) ' částka
                                                        ActiveCell(i, j) = Val(ud) / 100
                                                        j = j + 1
                                                        rr = Mid(textline, 16, 4) ' splatnost rok
                                                        mm = Mid(textline, 20, 2) ' splatnost mes
                                                        dd = Mid(textline, 22, 2) ' splatnost den
                                                        ActiveCell(i, j) = dd & "." & mm & "." & rr
                                                        j = j + 1
                                                        ud = Mid(textline, 293, 10) ' variabilní symb
                                                        ActiveCell(i, j) = ud
                                                        j = j + 1
                                                        ud = Mid(textline, 47, 10) ' konstantní symb
                                                        ActiveCell(i, j) = ud
                                                        j = j + 1
                                                        ud = Mid(textline, 303, 10) ' specifický symb
                                                        ActiveCell(i, j) = ud
                                                        j = j + 1
                                                        ud = Mid(textline, 240, 30) ' Zpráva pro příkazce
                                                        ActiveCell(i, j) = ud
                                                        j = j + 1
                                                        ud = Mid(textline, 313, 30) ' zpráva pro příjemce
                                                        ActiveCell(i, j) = ud
                                                End If
                                                zavet = zavet + 1
                                        Loop

                                        Close #1 ' Uzavře soubor.
                                        VV = i + volrad
                                        VP = VV + posun
                                        rozsah = "b" & VP & ":e" & VP + 1
                                        rrozsah = " " & VP & ":" & VP + 1
                                        ActiveSheet.Range(rozsah).Select
                                        Selection.Font.Bold = True
                                        Selection.Font.Size = 11
                                        Selection.HorizontalAlignment = xlLeft
                                        ActiveSheet.Rows(rrozsah).RowHeight = 20
                                        ActiveCell(1, 2) = "Počet příkazů:"
                                        ActiveCell(2, 2) = "Celkem Kč:"
                                        rozsah = "e" & VP
                                        ActiveSheet.Range(rozsah).Select
                                        Selection.NumberFormat = "0"
                                        Selection.HorizontalAlignment = xlRight
                                        vzorec = "=COUNT(e6:e" & VP - 1 & " )"
                                        ActiveSheet.Range(rozsah).Value = vzorec
                                        rozsah = "e" & VP + 1
                                        ActiveSheet.Range(rozsah).Select
                                        Selection.NumberFormat = "#,##0.00"
                                        Selection.NumberFormat = for1
                                        Selection.HorizontalAlignment = xlRight
                                        vzorec = "=SUM(e6:e" & VP - 1 & " )"
                                        ActiveSheet.Range(rozsah).Value = vzorec
                                        ActiveSheet.Protect

                                                If zavet = povet + 2 Then
                                                        xx = MsgBox("Soubor " & macesta & " byl úspěšně vytvořen." + Chr(13) + Chr(13) _
                                                        + " přečteno příkazů " & povet & Chr(13) _
                                                        + " zapsáno příkazů " & zavet - 2 & Chr(13) + Chr(13) _
                                                        + "Soubor dávky nyní zašlete pomocí služby mojebanka do KB." + Chr(13) _
                                                        + "Funkci pro načtení dávky najdete v aplikaci mojebanka pod položkou" + Chr(13) _
                                                        + "menu ""Dávkové příkazy"", pod odkazem ""Odeslání dávky do banky"". ", vbOKOnly)
                                                        xx = MsgBox("Přejete si opis na tiskárnu?", vbYesNo)
                                                        If xx = vbYes Then
                                                                ' OpisBtn_Click
                                                                pocstran = Int(i - 5 / 45) + 1
                                                                rozsah = "b6:k" & i + posun + volrad + 2
                                                                ActiveSheet.PageSetup.PrintArea = rozsah
                                                                With ActiveSheet.PageSetup
                                                                        .PrintTitleRows = "$3:$5"
                                                                        .PrintTitleColumns = ""
                                                                        .LeftHeader = "Dne &D"
                                                                        .CenterHeader = "&""Arial CE,tučné""&16Opis platebních příkazů do mojebanka&""Arial CE,obyčejné""" & Chr(10) & ""
                                                                        .RightHeader = "Strana &P"
                                                                        .LeftMargin = Application.InchesToPoints(0.78740157480315)
                                                                        .RightMargin = Application.InchesToPoints(0.78740157480315)
                                                                        .TopMargin = Application.InchesToPoints(0.984251968503937)
                                                                        .BottomMargin = Application.InchesToPoints(0.984251968503937)
                                                                        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
                                                                        .FooterMargin = Application.InchesToPoints(0.511811023622047)
                                                                        .PrintHeadings = False
                                                                        .PrintGridlines = False
                                                                        .PrintComments = xlPrintNoComments
                                                                        .CenterHorizontally = False
                                                                        .CenterVertically = False
                                                                        ' .Orientation = xlPortrait
                                                                        .Orientation = xlLandscape
                                                                        .Draft = False
                                                                        .PaperSize = xlPaperA4
                                                                        .FirstPageNumber = xlAutomatic
                                                                        .Order = xlDownThenOver
                                                                        .BlackAndWhite = False
                                                                        .Zoom = False
                                                                        .FitToPagesWide = 1
                                                                        .FitToPagesTall = pocstran
                                                                End With
                                                                ' ActiveWindow.SelectedSheets.PrintOut Copies:=1
                                                                ActiveWindow.SelectedSheets.PrintPreview
                                                                ' Sheets("Opis").Select
                                                                ' ActiveWindow.SelectedSheets.Visible = False
                                                                Sheets(prvlist).Activate
                                                        End If
                                                Else
                                                        xx = MsgBox("Nesouhlasí počet vět ve výstupním souboru " & macesta & ". Bude smazán", vbOKOnly)
                                                        Kill (macesta)
                                                End If

                                        Else
                                                xx = MsgBox("Soubor " & macesta & " se nevytvořil", vbOKOnly)
                                                Kill (macesta)
                                        End If
                                Else
                                        xx = MsgBox("Byly nalezeny chyby v zadání příkazů", vbOKOnly)
                                        Kill (macesta)
                                End If
                        End If
                End If
End Sub

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

Nahoru Odpovědět

9.6.2018 22:48

Chceš realizovat své sny? Probuď se!

Milan Janoušek

Člen

Milan Janoušek:14.6.2018 15:24

Díky ještě jednou. Funguje na 102 %.
@hojki.
M.

Nahoru Odpovědět

14.6.2018 15:24

Tarantula222

Člen

Tarantula222:14.6.2018 15:34

Za málo, ešte prosím označ odpoveď nech mám body k plusu. ;-)

Nahoru Odpovědět

14.6.2018 15:34

Chceš realizovat své sny? Probuď se!

Děláme co je v našich silách, aby byly zdejší diskuze co nejkvalitnější. Proto do nich také mohou přispívat pouze registrovaní členové. Pro zapojení do diskuze se přihlas. Pokud ještě nemáš účet, zaregistruj se, je to zdarma.

Zobrazeno 8 zpráv z 8.

Nejčastěji vyhledáváné

Diskuze: Nefunkční makro - "error time 445" na Excel 2016