Příspěvky uživatele

Tak tady bych potreboval alespon vedet, jak je obsah na tech listech strukturovany. Konkretne, jestli se jedna o spojitou tabulku nebo volne rozsypane bunky. Jestli volne rozsypane bunky, tak alespon kdyby nejspodnejsi bunka na danem liste byla vzdycky v urcitem sloupci, abych si oblast na kopirovani vzdycky osahal v tom danem sloupci. Taky by neskodilo vedet kolik sloupcu se ma kopirovat, jestli alespon toto bude konstanta anebo i toto bude potreba makrem zjistovat. Ukazka by zde fakt neskodila. Pokud je napr. na vsech listech tabulka se stejnou strukturou, tak zde ma smysl mit jenom jedno zahlavi, tj. nekopirovat ho pokazde. Taky by se mohlo hodit pridat jeste jeden pomocny sloupec s nazvem sesitu anebo listu, okdud se to zkopirovalo. Zkratka, pokud tam mas citliva data, tak je nejak anonymizuj, ale ukazku ze ktere poznam to co potrebuju vedet, kazdopadne priloz.
Ale stejne si myslim, ze to tady uz urcite muselo byt. Zkousel jsi tlacitko vyhledat?

Bez vzoroveho sesitu kde bude jasne poznat, co je soucasny a co ma byt cilovy stav, jde opet o mrhani nasi energii. Po precteni, soustredeni a vizualizaci problemu me napada hned nekolik doplnujicich otazek, ktere maji zasadni vliv na reseni.
To je past vedle pasti

Kdyby to nekomu fakt neslo nastavit, tak se to jeste da udelat "hrubou silou", tedy bunku po bunce. Vystup muze byt *.txt nebo *.csv

Sub ExportCSVStredniky()
Dim rOblast As Range, rRadek As Range, rBunka As Range
Dim s As String

Set rOblast = ActiveSheet.UsedRange
Open ThisWorkbook.Path & "\bubu_1.csv" For Output As #1

For Each rRadek In rOblast.Rows
For Each rBunka In rRadek.Cells
If IsNumeric(rBunka.Value) And Not IsDate(rBunka.Value) Then
s = s & rBunka.Value & ";"
Else
If IsDate(rBunka.Value) Then rBunka.NumberFormat = "dd/mm/yyyy"
s = s & rBunka.Text & ";"
End If
Next
Print #1, s
s = ""
Next

Close #1

End Sub

do bunky O2 si dej vzorec: =COUNTIF(B:B,$A2)
a mysi ho natahni ho az do bunky Z2
Do bunky N2 dej tento vzorec =IF(SUM(O2:Z2)=12,A2,0)
Jestli mas cesky excel, tak misto IF bude KDYZ a misto SUM bude SUMA

No a pak techto 13 vzorcu nakopiruj do oblasti N2:Z286

Vraci to pouze 17 shod. Akorat ten soubor temi vzorci nabobtnal na neuveritelnych 5,4MB

Tak zde je funkcni nastrel:
Option Explicit

Sub Filtr123()
'toto funguje za predpokladu, ze na danem liste je jen jedna tabulka s filtrem

Dim ws As Worksheet
Dim iRows As Long, i As Long, j As Long, iStartRow As Integer, iStartCol As Integer
Dim cKol As New Collection
Dim pPole()
Dim strX As String

Set ws = Worksheets("Skaly")
'zjisti, jestli tam vubec je filtr
If Not ws.AutoFilterMode Then
MsgBox "Na liste " & ws.Name & " neni zadny filtr"
Exit Sub
End If

'osahej oblast tabulky, pocet radku, prvni radek, prvni sloupec
'pocet radku tabulky
iRows = ws.AutoFilter.Range.Rows.Count
'prvni radek tabulky (doufam, ze zahlavi neobsahuje vice sloupcu nebo sloucene bunky!)
'ze radky tabulky bez zahlavi by mely zacinat na
iStartRow = ws.AutoFilter.Range.Cells(1).Row + 1
'kdyby ne, klidne to napis natvrdo iStart = 5
iStartCol = ws.AutoFilter.Range.Cells(1).Column

'napln kolekci (kvuli duplicitam)
On Error Resume Next 'pripadna duplicita vyhodi chybu, ale budeme ji ignorovat
For i = iStartRow To iStartRow + iRows - 2
cKol.Add Item:=CStr(Cells(i, "L").Value), Key:=CStr(Cells(i, "L").Value) 'budeme to tam davat jako string, proto CStr
Next i
On Error GoTo 0

'tak mame kolekci jedinecnych hodnot
'vsechno krome "2","-","AF" narveme do pole
For i = 1 To cKol.Count
strX = cKol(i)
If strX <> "2" And strX <> "-" And strX <> "AF" Then
j = j + 1
ReDim Preserve pPole(1 To j)
pPole(j) = strX
End If
Next i

'zafiltruj
ws.AutoFilter.Range.AutoFilter Field:=11, Criteria1:=pPole, Operator:=xlFilterValues

End Sub

Coze, tam jsou 3 tabulky na lednom liste?
Na kterem radku je zahlavi te tabulky3?
Jake pismeno ma ten 11 sloupec?
Ten pripadny filtr bude v danem sloupci anebo v jinych sloupcich?

Napada me pouze komplexni reseni, kdy se nejdriv nactou hodnoty v danem sloupci do kolekce (aby nebyly duplicity).
Pak se v dalsim cyklu budou prochazet jednotlive prvky kolekce a v tomto cyklu by se z kolekce nacitaly do pole pouze ty hodnoty, ktere chceme po odfiltrovani videt.
No a pak to pole predame jako argument filtru.
Pokud do zitrka nekdo neprijde s necim jednodussim, muzu napsat prislusnou proceduru. Alespon bych potreboval vedet o ktery sloupec v tabulce se jedna a prani, aby pod tabulkou uz nebyly zadne neprazdne bunky

Not bad! Posilam taky svuj polotovar, ktery jsem pred lety pouzival, nez me to prestalo bavit. Jenom pro inspiraci: je tam dost uzitecna funkce sledovani spatnych odpovedi u konkternich slovicek ktera tezko lezla do hlavy a trvalo to na dosazeni urciteho poctu spravnych odpovedi... Pak v tom jeste pokracoval kolega a opatril to formularem, vnesl do toho komfort a dalsi funkcionality, ale ani nevim, kde je tomu konec

Zkouseni cizojazycnych slovicek excelem je, rekl bych, klasicka VBA vyzva. Zacina to nadejne, pak se k tomu pridava statistika, user form na ovladani aplikace atd.
Nic proti tomu, ale nakonec jediny efekt z toho je hlubsi znalost VBA pro okruh autoru, a to spise jako vedlejsi efekt cteni helpu

. Sam patrim mezi lidi, co se uci anglicky (rekl bych, ze uz to docela umim), ale excelove slovickove aplikace k tomu prispely minimalne. Na netu jsou podstane lepsi veci (napr. Smart Tests na helpforenglish.cz). Klidne se vydej excelovym smerem, ale plody to nevyda, alespon ne tam, kde bys je cekal. Jak zpiva nechvalne znamy H.N: "kolik bylo nas a stale nic..."

Uvedom si, ze ty klasicke excelove ulohy maji velke omezeni v tom, ze ve finale musis vytukat na klavesnici slovicko. A mas prakticky jenom moznost Yes/No v textovem porovnani se "spravnou" odpovedi. Nechci zminovat potize s diakritikou u lidi, kteri maji neceskou verzi excelu... Pokrocilejsi verze uz umi nabizet misto toho volbu z vice moznosti, coz je vyrazne lepsi, ale to uz pak prichazis k poznani, ze toto neni ta prava uloha pro excel. At least this is my experience

Sorry Lopi, ale ten Tvuj "mujPlan" je pekne nechutna zalezitost. Mne to pripomina ty otravne prodejce a telefonisty, nabizece cehokoli. Fakt se nedivim, ze zatim neprisla zadna odpoved

tady je to na dobrovolne bazi.

Tak zkus nasledujici kod. Neznam strukturu Tveho listu s KT, tedy nevim kam to vypsat, takze provizorne jsem to udelal tak, aby to vypsalo zafiltrovane polozky na novy list. (Nebude problem to zobrazit jinde, az bude jasno kam).
Co ale asi budes muset upravit v kodu je volba spravneho indexu (cislo sloupce v DB, na ktery je nasazen filtr KT) anebo vypsat jeho nazev. Je to v kodu okomentovano, nemam strach, ze by ses na tomto zasekl.

Sub VypisFiltruPoleKT()

Dim i As Integer, j As Integer
Dim wsPiv As Worksheet, wsNew As Worksheet
Dim KT1 As PivotTable, KTpole As PivotField

Set wsPiv = ActiveSheet 'list s KT

'zjisti, jestli tam opravdu nejaka KT je
On Error Resume Next
'Kdyby na tom liste bylo vice KT, tak zkusmo indexem najdes tu spravnou
Set KT1 = wsPiv.PivotTables(1)

'pokud neni, hodi to chybu
If Err <> 0 Then
MsgBox "Na aktivnim liste neni zadna KT"
GoTo fiNito
End If
On Error GoTo 0

'pridej novy list, at vime kam vypsat filtrovane polozky
Set wsNew = Worksheets.Add
'zde je potreba urcit spravne pole KT, ktere nas zajima
' bud pomoci indexu: KT1.PivotFields(i), pricemz v zavorce je cislo sloupce z databaze
' anebo natvrdo, napr. KT1.PivotFields("Zakaznik")
Set KTpole = KT1.PivotFields(4)

wsNew.Cells(1, 1) = KTpole.Name
j = 1

For i = 1 To KTpole.PivotItems.Count
If KTpole.PivotItems(i).Visible = True Then
j = j + 1
wsNew.Cells(j, 1) = KTpole.PivotItems(i)
End If
Next i

fiNito:
On Error GoTo 0

End Sub

tak jak jsi to popsal, tak reseni je zobrazit filtr a Print screen, ale to zrejme nemas na mysli.
Pokud bych se snazil domyslet co asi tak zadas, tak zafajfkovane polozky z filtru KT se daji nacist pomoci VBA procedury a tedy i nekam vypsat. Ale nevim, jestli toto je to co chces

Zkus ten csv ulozit do dane slozky rucne. Jestli to nepujde, problem nebude v makru. Jestli to ale rucne pujde, tak to rucne uloz jeste jednou, ale se zapnutym zaznamem makra. A porovnej strPath (text ktery je v teto promenne v okamziku SaveAs) s textem, ktery vygenerovalo zaznamenane makro (myslim text za SaveAs:= az po prvni carku)
Pokud bys nahodou nevedel, jak zjistit hodnotu strPath, tak bud dokrokujes v tom puvodnim makru pomoci F8 do prislusneho mista anebo hodis zarazku (F9) na prislusny radek kodu a spustis to pomoci F5 a procedura se zastavi na zarazce. A pak v Immediate Window (to prazdne okno vpravo dole) napis:
?strPath a odbouchni to enterem. Super vec pro hledani problemu

Ten tlusty radek je spatne hned v nekolika ohledech.
Za prve se nevi kam ten sesit ukladat, za druhe to je textove spatne pospojovane.
Takze definuj si jeste nejakou textovou promennou, treba:
Dim strPath as String

a pod tento radek:
Set wbX=ActiveWorkbook
hod kod:
strPath = wbX.Path
pak do toho stringu pridas zpetne lomitko:
strPath = strPath & "\"a pak do toho pridas ten novy nazev:
strPath = strPath & Range("A1")a pak do toho pridas format:
strPath = strPath & ".xls"a pak ten tlusty radek bude takhle:
wbX.SaveAs Filename:= strPath
Pochopitelne se to textove vyskladani dalo udelat primo v tom radku SaveAs, ale chtel jsem Ti ukazat jak se spojuji textove retezce

Jedna dobra rada by byla: formuluj problem dostatecne a srozumitelne

. Je zde hodne neznamych, napr. verze excelu, taky z uvedeneho zapisu prikladu jsem nebyl schopen zjistit co myslis. Nejlepsi byva priloha

Ale obecne k podminenemu formatovani: Musel bys s bunkou prenest na druhy list i tu ridici bunku (bacha na absolutni a relativni adresu). Pokud ridici bunka zustava na puvodnim liste, tak pouhym zkopirovanim formatovane bunky na druhy list se to formatovani bude odkazovat na nejakou bunku na druhem liste. V tom pripade musis na tom druhem liste ve formatovane bunce zmenit uvnitr formatovaciho pravidla (vzorce) tu obycejnou adresu na 2D odkaz.
Tedy misto: $A$1 tam musi byt List1!$A$1
Toto lze provest makrem, alespon ve verzi 2010

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje