Mám problém s tymto kódom.
Celý kód prebehne v poriadku, no ked sa prilepia hodnoty do "vystup" excel mi akoby zamrzne a ide iba vba editor.Musim zošit qir dbs.xlsm dať križikom akoby uzavrieť a potom storno...nasledne sa excel znova rozbehne..neviem si rady..
Vedeli by ste mi niekto pomôcť?
Kód: Vybrat vše
Public Function f_Is_WkBk_Open(ByVal f_sWkBk As String) As Boolean
Dim oWkBk As Workbook
Dim bIsOpen As Boolean
bIsOpen = False
For Each oWkBk In Application.Workbooks
If InStr(f_sWkBk, oWkBk.Name) > 0 Then
bIsOpen = True
Exit For
End If
Next oWkBk
f_Is_WkBk_Open = bIsOpen
Set oWkBk = Nothing
End Function
Sub zapis_qir_dbs()
Dim vystup As Worksheet
Dim vstup As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim hodnoty As Range
Dim lCount As Long
Dim strSheetName As String
Set vstup = ActiveWorkbook.ActiveSheet
'hodnoty na pomocny listn ak koniec nazvu lisu (B) nezapisovať
strSheetName = ActiveSheet.Name
If Right(strSheetName, 3) = "(B)" Then
GoTo koniec
End If
'hodnoty na pomocny list
Application.ScreenUpdating = False
ActiveSheet.Range("l6").Copy
Sheets("pomocny_list").Range("a1").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("f10").Copy
Sheets("pomocny_list").Range("a2").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("f9").Copy
Sheets("pomocny_list").Range("a3").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("f8").Copy
Sheets("pomocny_list").Range("a4").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("f7").Copy
Sheets("pomocny_list").Range("a5").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("f6").Copy
Sheets("pomocny_list").Range("a6").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("l7").Copy
Sheets("pomocny_list").Range("a7").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("l8").Copy
Sheets("pomocny_list").Range("a8").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
ActiveSheet.Range("l9").Copy
Sheets("pomocny_list").Range("a9").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = False
Application.ScreenUpdating = True
Set myCopy = Sheets("pomocny_list").Range("hodnoty")
myCopy.Copy
'cells to copy from Input sheet
oCol = 2 'starting column where copied data is pasted
Dim btest As Boolean
btest = f_Is_WkBk_Open("C:\Documents and Settings\user\Dokumenty\Forma reportov_all\prepojene subory\qir dbs.xlsm")
If btest Then
GoTo dalej
Else
Workbooks.Open Filename:="C:\Documents and Settings\user\Dokumenty\Forma reportov_all\prepojene subory\qir dbs.xlsm"
End If
dalej:
Windows("qir dbs.xlsm").Activate
Set vystup = Worksheets("QIR dbs")
With vystup
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With vstup
If Application.CountA(myCopy) <> myCopy.Cells.Count Then
MsgBox "Prosím vyplňte všetky údaje!"
Cancel = True
Exit Sub
End If
End With
With vystup
With .Cells(nextRow, "A")
.Value = Format(Date, "DD.MM.YYYY")
End With
'.Cells(nextRow, "B").Value = Application.UserName
Cells(nextRow, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
oCol = oCol + myCopy.Cells.Count
'clear input cells
'With myCopy
' .Cells.ClearContents
' .Cells(1).Select
'End With
koniec:
End Sub
Application
