9622_evidence-kontroly.7z
No konecne jasna formulace!
Jinak ta hovadina neni samotna hlaska, ale ten fakt, ze pro toto se pouzila sloucena bunka. Ten text prece klidne mohl bydlet v obycejne bunce, stejne by byl videt. Zkratka sloucene bunky jsou zlo a pokud to jde, je dobre se jim vyhnout
Zkus nahradit cely kod na modulu AkceOprava timto:
Option Explicit
Private Sub Kopirovani_stranky_za_ucelem_oprav()
Run "AkceFormular.ProStart"
On Error Resume Next
Sheets("Oprava").Select
If Err.Number = 0 Then
If MsgBox("Odstranit List /Oprava ?", vbExclamation + vbYesNo) = vbYes Then
Application.DisplayAlerts = False
Sheets("Oprava").Delete
Application.DisplayAlerts = True
Else
GoTo POKRACOVAT
End If
End If
On Error GoTo 0
Sheets.Add.Name = "Oprava"
Sheets("Oprava").Move After:=Sheets(3)
POKRACOVAT:
With Sheets("Oprava")
.Activate
.Cells.Clear
rdLast = Sheets("Hárok1").Cells.SpecialCells(xlCellTypeLastCell).Row
Sheets("Hárok1").Range("A1:N" & rdLast).Copy .Range("A1")
For slR = 1 To Range("A:N").Columns.Count
.Columns(slR).ColumnWidth = Sheets("Hárok1").Columns(slR).ColumnWidth
Next slR
For rdR = 1 To rdLast
.Rows(rdR).RowHeight = Sheets("Hárok1").Rows(rdR).RowHeight
Next rdR
For Each xCel In .Range("A1:N" & rdLast)
If Not IsEmpty(xCel) Then xCel = xCel.Value
Next xCel
End With
ActiveWindow.Zoom = 76
Call PrepisKomentare
Run "AkceFormular.ProKonec"
End Sub
Sub PrepisKomentare()
Dim wsOpr As Worksheet
Dim iStart1 As Integer, iStart2 As Integer, iKonec1 As Integer, iKonec2 As Integer, i As Integer, iMxRow As Integer, j As Integer, c As Integer, d As Integer, iDelka As Integer
Dim iRow As Integer, iCol As Integer
Dim strText As String
Dim boHelp As Boolean
Dim sloupce
sloupce = Array("1", "3", "6", "8", "10")
Set wsOpr = Worksheets("Oprava")
wsOpr.Activate
'zjisti kde konci spodni tabulka, radeji to vem pres vice sloupcu
iMxRow = Application.WorksheetFunction.Max(Range("A65000").End(xlUp).Row, Range("B65000").End(xlUp).Row, Range("C65000").End(xlUp).Row, Range("D65000").End(xlUp).Row)
'zjisti kde zacina a konci prvni a druha tabulka - chytni se podle sloupce F -"minuty"
For i = 3 To iMxRow
If UCase(Cells(i, "F")) = "MINUTY" Then
iStart1 = i + 1
End If
If UCase(Cells(i, "D")) = "CELKEM MIN." Then
iKonec1 = i - 1
Exit For
End If
Next i
For i = iMxRow To iStart1 Step -1
If UCase(Cells(i, "D")) = "CELKEM MIN." Then
iKonec2 = i - 1
End If
If UCase(Cells(i, "F")) = "MINUTY" Then
iStart2 = i + 1
Exit For
End If
Next i
'prepis komentare z tab1
iRow = iKonec1 + 3 'iRow je radek, do ktereho se prepise komentar
iCol = 1 'iCol je sloupec, do ktereho se prepise komentar: 'pro sloupec A
d = 0 'd je poradi sloupce v matici Array("1", "3", "6", "8", "10") neboli A,C,F,H,J
'a tomu odpovida cislo sloupce do ktereho se budou psat komentare:
For i = iStart1 To iKonec1
iDelka = 0
On Error Resume Next
iDelka = Len(Cells(i, "H").Comment.Text)
On Error GoTo 0
If iDelka > 1 Then
strText = Cells(i, "H").Comment.Text 'oddelame z textu 13 znaku Kod operace:
strText = Right(strText, Len(strText) - 13)
c = c + 1 ' pomocna promenna
If c Mod 6 = 0 Then 'prehod sloupec
d = d + 1
iCol = CInt(sloupce(d))
iRow = iRow - 4
Else
iRow = iRow + 1
End If
'zapis komentar
Cells(iRow, iCol) = strText
End If
Next i
'prepis komentare z tab2
iRow = iKonec2 + 3 'iRow je radek, do ktereho se prepise komentar
iCol = 1 'iCol je sloupec, do ktereho se prepise komentar: 'pro sloupec A
d = 0 'd je poradi sloupce v matici Array("1", "3", "6", "8", "10") neboli A,C,F,H,J
'a tomu odpovida cislo sloupce do ktereho se budou psat komentare:
For i = iStart2 To iKonec2
iDelka = 0
On Error Resume Next
iDelka = Len(Cells(i, "H").Comment.Text)
On Error GoTo 0
If iDelka > 1 Then
strText = Cells(i, "H").Comment.Text 'oddelame z textu 13 znaku Kod operace:
strText = Right(strText, Len(strText) - 13)
c = c + 1 ' pomocna promenna
If c Mod 6 = 0 Then 'prehod sloupec
d = d + 1
iCol = CInt(sloupce(d))
iRow = iRow - 4
Else
iRow = iRow + 1
End If
'zapis komentar
Cells(iRow, iCol) = strText
End If
Next i
End Subcitovat
Jinak ta hovadina neni samotna hlaska, ale ten fakt, ze pro toto se pouzila sloucena bunka. Ten text prece klidne mohl bydlet v obycejne bunce, stejne by byl videt. Zkratka sloucene bunky jsou zlo a pokud to jde, je dobre se jim vyhnout
Zkus nahradit cely kod na modulu AkceOprava timto:
Option Explicit
Private Sub Kopirovani_stranky_za_ucelem_oprav()
Run "AkceFormular.ProStart"
On Error Resume Next
Sheets("Oprava").Select
If Err.Number = 0 Then
If MsgBox("Odstranit List /Oprava ?", vbExclamation + vbYesNo) = vbYes Then
Application.DisplayAlerts = False
Sheets("Oprava").Delete
Application.DisplayAlerts = True
Else
GoTo POKRACOVAT
End If
End If
On Error GoTo 0
Sheets.Add.Name = "Oprava"
Sheets("Oprava").Move After:=Sheets(3)
POKRACOVAT:
With Sheets("Oprava")
.Activate
.Cells.Clear
rdLast = Sheets("Hárok1").Cells.SpecialCells(xlCellTypeLastCell).Row
Sheets("Hárok1").Range("A1:N" & rdLast).Copy .Range("A1")
For slR = 1 To Range("A:N").Columns.Count
.Columns(slR).ColumnWidth = Sheets("Hárok1").Columns(slR).ColumnWidth
Next slR
For rdR = 1 To rdLast
.Rows(rdR).RowHeight = Sheets("Hárok1").Rows(rdR).RowHeight
Next rdR
For Each xCel In .Range("A1:N" & rdLast)
If Not IsEmpty(xCel) Then xCel = xCel.Value
Next xCel
End With
ActiveWindow.Zoom = 76
Call PrepisKomentare
Run "AkceFormular.ProKonec"
End Sub
Sub PrepisKomentare()
Dim wsOpr As Worksheet
Dim iStart1 As Integer, iStart2 As Integer, iKonec1 As Integer, iKonec2 As Integer, i As Integer, iMxRow As Integer, j As Integer, c As Integer, d As Integer, iDelka As Integer
Dim iRow As Integer, iCol As Integer
Dim strText As String
Dim boHelp As Boolean
Dim sloupce
sloupce = Array("1", "3", "6", "8", "10")
Set wsOpr = Worksheets("Oprava")
wsOpr.Activate
'zjisti kde konci spodni tabulka, radeji to vem pres vice sloupcu
iMxRow = Application.WorksheetFunction.Max(Range("A65000").End(xlUp).Row, Range("B65000").End(xlUp).Row, Range("C65000").End(xlUp).Row, Range("D65000").End(xlUp).Row)
'zjisti kde zacina a konci prvni a druha tabulka - chytni se podle sloupce F -"minuty"
For i = 3 To iMxRow
If UCase(Cells(i, "F")) = "MINUTY" Then
iStart1 = i + 1
End If
If UCase(Cells(i, "D")) = "CELKEM MIN." Then
iKonec1 = i - 1
Exit For
End If
Next i
For i = iMxRow To iStart1 Step -1
If UCase(Cells(i, "D")) = "CELKEM MIN." Then
iKonec2 = i - 1
End If
If UCase(Cells(i, "F")) = "MINUTY" Then
iStart2 = i + 1
Exit For
End If
Next i
'prepis komentare z tab1
iRow = iKonec1 + 3 'iRow je radek, do ktereho se prepise komentar
iCol = 1 'iCol je sloupec, do ktereho se prepise komentar: 'pro sloupec A
d = 0 'd je poradi sloupce v matici Array("1", "3", "6", "8", "10") neboli A,C,F,H,J
'a tomu odpovida cislo sloupce do ktereho se budou psat komentare:
For i = iStart1 To iKonec1
iDelka = 0
On Error Resume Next
iDelka = Len(Cells(i, "H").Comment.Text)
On Error GoTo 0
If iDelka > 1 Then
strText = Cells(i, "H").Comment.Text 'oddelame z textu 13 znaku Kod operace:
strText = Right(strText, Len(strText) - 13)
c = c + 1 ' pomocna promenna
If c Mod 6 = 0 Then 'prehod sloupec
d = d + 1
iCol = CInt(sloupce(d))
iRow = iRow - 4
Else
iRow = iRow + 1
End If
'zapis komentar
Cells(iRow, iCol) = strText
End If
Next i
'prepis komentare z tab2
iRow = iKonec2 + 3 'iRow je radek, do ktereho se prepise komentar
iCol = 1 'iCol je sloupec, do ktereho se prepise komentar: 'pro sloupec A
d = 0 'd je poradi sloupce v matici Array("1", "3", "6", "8", "10") neboli A,C,F,H,J
'a tomu odpovida cislo sloupce do ktereho se budou psat komentare:
For i = iStart2 To iKonec2
iDelka = 0
On Error Resume Next
iDelka = Len(Cells(i, "H").Comment.Text)
On Error GoTo 0
If iDelka > 1 Then
strText = Cells(i, "H").Comment.Text 'oddelame z textu 13 znaku Kod operace:
strText = Right(strText, Len(strText) - 13)
c = c + 1 ' pomocna promenna
If c Mod 6 = 0 Then 'prehod sloupec
d = d + 1
iCol = CInt(sloupce(d))
iRow = iRow - 4
Else
iRow = iRow + 1
End If
'zapis komentar
Cells(iRow, iCol) = strText
End If
Next i
End Subcitovat
RSS nejnovější články