Příspěvky uživatele
< návrat zpět
Ale vzdyt mou odpoved mas: pouzij ten kod. Ty tri radky, ktere delali neco jineho nez potrebujes (kopirovani listu do jednoho souboru) jednoduse vymaz, a misto nich tam dej procistene svoje makro. Vysledkem bude procedura, ktera postupne otevre vsechny soubory, ktere oznacis a vykona na nich prikazy Tveho makra.
Pokud se vse ma odehravat na prvnim listu kazdeho oznaceneho soboru, mohl bys tam pro sichr vlozit, pote co se dany soubor otevre, prikaz pro aktivaci prvniho listu: Worksheets(1).Activate Co by jeste mohlo zlobit je tento radek kodu:
.Filters.Add "Excel", "*.xls" Pokud mas ty svoje soubory v jinem excel. formatu, napr: xlsx, xlsm, csv... tak bud si s tim filtrem pohraj anebo ho klidne vynech, pak uvidis vsechny typy souboru v danem adresari.
Kod pro ulozeni souboru je
wbX.Save anebo rovnou i se zavrenim
wbX.Close(1)Tedy udelej jak rikam, jestli se vyskytne problem klidne pomuzu, pokud uvidim, ze ses vynalozil usili
Tak se podivej na tento prispevek zpred dvou dnu: http://wall.cz/index.php?m=topic&id=9675
Je tam kod, ten te vybidne k otevreni zvoleneho adresare, kde oznacis soubory, ktere potrebujes. Vykonne radky jsou pouze tyto tri, vse ostatni v kodu zrejme zustane stejne.
'nakopiruj listy do wb
For j = 1 To wbX.Sheets.Count
wbX.Sheets(j).Copy after:=wb.Sheets(wb.Sheets.Count)
Next j
Takze tyto 3 radky vyhod a misto nich vloz to svoje nahrane makro a uvidis vysledek. Btw. pises soubory, ale uz se nezminujes o listech, takze asi se ti jedna jen o prvni list. Ma nejaky konstantni nazev?
Jinak vsechny radky kde scrollujes klidne vymaz. Ty nemaji prakticky zadny vliv na funkci.
Jo a dulezite: nejdriv si ty soubory zazalohuj. Doporucuji si hodit VBA okno na pulku obrazovky a excel na druhou pulku. Pak klikej na F8 ve VBA okne a budes videt prislusnou odezvu v excelu. Nejlepsi zpusob, jak se rychle obeznamit s "makry"
Jen tak narychlo naplacane, trochu se to komplikovalo tim, ze po vymazani listu se zmenil pocet listu v sesitu. Ale nejak jsem to zpytlikoval 
Sub KillPrazdnyList()
Dim ws As Worksheet
Dim i As Long, j As Long, c As Integer
c = ThisWorkbook.Worksheets.Count
Application.DisplayAlerts = False
For i = 1 To c
Set ws = Worksheets(i)
ws.Activate
'Debug.Print ws.Name
For j = 1 To 30
If ws.Cells(65000, j).End(xlUp).Row > 1 Then Exit For
Next j
If j > 29 Then
On Error Resume Next
ws.Delete
If Err = 0 Then
c = c - 1
i = i - 1
If i = c Then Exit For
End If
On Error GoTo 0
End If
Next i
Application.DisplayAlerts = True
End Sub
Je to moc velke sousto na koncentraci. Takze to zjednodusme na jednotlive kroky.
Zkusil jsi pouzit Color misto ColoIndex? Tim by se mohla cast problemu vyresit.
Co tam mas dal?
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 Sub
Co myslis pod pojmem "z buněk ve sloupci H zkopírujou jen komentáře do prostoru pod tabulkou."
Jen je jednoduse zkopirovat do sloupce H pod tabulku?
Na kterem radku pod tabulkou zacit? Pridavat pritom radky?
Ta sloucena bunka s tim dlouhym prohlasenim tam taky prekazi, proc tam je? Jses autor, tak se snaz vyhybat takovym hovadinam.
Tak zde by mohla pomoct dynamicky pojmenovana oblast - tedy oblast ktera se automaticky meni podle poctu radku.
Vvytvoris ji v NameManageru (SpravceNazvu). Priklad dynamicke oblasti na liste main:
=OFFSET(main!$A$2,0,0,COUNTA(main!$A:$A)-1,22)
Jsou to sloupce A:V (to definuje ta 22-ka) a pocet radku je presne podle skutecnosti.
A tuto oblast uvedes pod jejim nazvem jako zdroj KT.
To by mohlo byt resenim
Tak uz to mam otevrene, nainstaloval jsem si otravny WinZip, ale je to jenom trial verze, takze zbytecny opruz. Doted jsem si vystacil s rar a zip
Aby se dal zjistit rozsah tabulky, je potreba se neceho chytit. Zacatek tabulky se da chytnout podle zahlavi (sloucene bunky sice nejsou moc stastne reseni, ale i to se da poresit). Spodni radek tabulky by se dal chytnout podle textu "celkem min." Jedna se o komentare ve sloupci "G" do bunky "G"?
no nedovedu otevrit prilohu, ale jen z hlavy:
Cislo posledniho radku tabulky se zjistuje "skokem odspodu" (musis zvolit vhodny sloupec tabulky, ktery nema ani jednu bunku prazdnou, dejme tome, ze je to sloupec "B"). Samozrejme, ze v danem sloupci pod tabulkou uz nesmis mit zadne neprazdne bunky!
Dim iMaxRad as long, i as Long
'cislo posledniho radku:
iMaxRad = Range("B65000").End(xlUp).Row
pokud bychom ale meli nasazeny filtr v tabulce, tak by nam to nemuselo vratit spravny radek, takze jeste pred tento kod bycho meli umistit nasledujici oddelani filtru:
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
A pak jedes postupne pro kazdy radek (dejme tomu, ze tabulka zacina na radku 2, komentare jsou ve sloupci "B" a chceme je narvat do slouce "G"
For i = 2 To iMaxRad
Cells(i,"G") = Cells(i,"B").Comment.Text
Next i
For je systemove slovo, kterym zacina nejaky cyklus. V tomto radku taky definujeme odkud a dokud ma cyklus trvat. Zde si pomahame promennou i, ktera reprezentuje cislo radku, a ta se ma menit od 2 az po cislo posledniho radku iMaxRad.
Pak tam je jeden radek prikazu, ktery cosi dela, pricemz to vzdy provadi na i-tem radku.
Samozrejme, ze tento radek by mohl byt napsan i jinak:
Cells(i,7) = Cells(i,2).Comment.Text
anebo
Range("G:" & i) = Range("B:" & i).Comment.Text nebo dalsimi zpusoby, zalezi na vkusu
Next je systemove slovo, ktere vraci cyklus zpatky na For a to az do te doby, nez i dosahne posledniho radku iMaxRad. Anebo nez narazi na tzv. opustak cyklu exit for, ale to tady nemame. Neni to tak tezky, ze ne?
Aha, tak mezi next j a next i vraz prikaz"
wbX.Close(0)
Pisi z hlavy, snad se nepletu
Jeste bych k tomu dodal, Funkce WEEKDAY (ze by to v ceskem Excelu byl DENTYDNE?) vraci cislo od 1 do 7, coz taky vraci, ale ty bunky maji specialni custom format a ten to rovnou prevadi na zkratky dnu.
Proto jsem v makru musel pouzit vlastnost Cells(x,y).Text
Pokud bych tam nechal jenom Cells(x,y) anebo Cells(x,y).Value, tak to ponekud nezvykle vraci datumovou hodnotu (od 12/31/1899 do 1/6/1900).
Pokud bychom se chteli rozhodovat podle skutecne hodnoty, kteru vraci vzorec WEEKDAY (cisla 1 az 7), tak pro toto pouzijeme vlastnost bunky .Value2
Takze ten rozhodovaci radek v makru by mohl byt i takhle:
If Cells(i, "A").Value2 = 7 Or Cells(i, "A").Value2 = 1 Then
Sobote odpovida sedmicka (amici jsou divni )
je to sice divne delat to makrem, mnohem lepsi je podminene formatovani, ale budiz to cvicny priklad jednoducheho makra (pokud mas cesky excel, tak to samozrejme zmenis na ceske nazvy dnu):
Sub Proba()
Dim i As Integer
For i = 2 To 32
If Cells(i, "A").Text = "Sat" Or Cells(i, "A").Text = "Sun" Then
Cells(i, "A").Interior.ColorIndex = 4
End If
Next i
End Sub
Uživatelské menu
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články