• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

Private Sub CommandButton2_Click()
Dim my_range As Range
Dim c As Range
Dim radek As Long
Dim Pocet As Long

Set my_range = ActiveSheet.Range("K1:K1000")

For Each c In my_range.Cells
If c.Borders(xlEdgeBottom).LineStyle = xlDouble Then
Pocet = Pocet + 1
If Pocet = 2 Then radek = c.Row
End If
Next c
MsgBox radek
End Sub

Niečo takéto ? Dať to do Personal.xlsb a vytiahnuť tlačítko na lištu, alebo to šupnúť do doplnku (prípadne prihodiť do nejakého stávajúceho doplnku).
Sub Export_ActiveSheet()
Dim varResult As Variant
varResult = Application.GetSaveAsFilename("", FileFilter:="Excel File (*.xlsx), *.xlsx", Title:="Export ActiveSheet to Excel File")
If varResult <> False Then
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=varResult, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, Local:=True
ActiveWorkbook.Close False
If Err.Number <> 0 Then MsgBox "Export Sheet Error !", vbCritical, "Error"
Application.DisplayAlerts = True
End If
End Sub

Ukladať zošit po každej zmene každej bunky ? To bude stráášne zdržovať. Navyše to zrušenie kopírovania, nemá na rováši Vaše makro, ale samotné ukladanie Excelu. Skúste si urobiť Ctrl+C a dať iba Save. Kopírovanie sa Vám zruší.

Hmm, problém bude možno v nejakej MS kulišárne. Takýto rýchly postup FindFormat totiž funguje iba a len, ak pred spustením makra rovnakým spôsobom dám prehľadať cez Ctrl+F formát, kde nastavím dvojitú čiaru a dám hľadať. Ak toto nahrám cez záznamník, funguje, ale iba do prípadu, pokým nevynulujem nastavenie hľadacieho okna. Ak to urobím, makro prestane fungovať, aj keď v makre nastavujem presne to isté čo nahral záznamník. Presne rovnako sa to správa na Office 2010, 2016, 2019. Musí byť najskôr použité manuálne hľadanie.

Bolo by to oproti prehľadávaniu buniek po jednej rýchlejšie. Možno niekto niečo poradí.

Ak teda cez cyklus, a jedná sa o jednotnú oblasť (jeden stĺpec) tak skúste hľadať odzadu pomocou Cells(y,x). Pretože potrebujete nájsť poslednú (alebo iba presne druhú čiaru ???, potom Vám tam chýba ukončenie cyklu po nájdení), nie všetky od začiatku.

Akú máte verziu Office ? Mne ten Váš súbor funguje správne (Office 2019 x64 SK)

Napr.:
If Not rngBunka Is Nothing Then Moja_Oblubena_Premenna = rngBunka.Row

Alebo do inkriminovanej časti doplnte:
On Error Resume Next
With ActiveSheet.Columns("K:K")
Moja_Oblubena_Premenna = .Find(What:="", After:=.Cells(Rows.Count), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=True).Row
End With
On Error GoTo 0

V oboch prípadoch definujte Moja_Oblubena_Premenna ako Long
Dim Moja_Oblubena_Premenna as Long

Aký Vám to vráti výsledok? Mne 0. A to je zle.

Napr.:
Sub Makro1()
Dim rngBunka As Range
With Application.FindFormat.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With

With ActiveSheet.Columns("K:K")
Set rngBunka = .Find(What:="", After:=.Cells(Rows.Count), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=True)
End With

If Not rngBunka Is Nothing Then rngBunka.Activate
End Sub

No a keby sa po vykonaní vašeho makra vymazal aj zoznam Undo ?
Sub makro()
Range("I1").ClearContents
ThisWorkbook.Saved = True
End Sub
Teda sa napr. vymaže nejaká nepotrebná bunka, čo zruší doterajšiu históriu Undo (lebo VBA nevytvára Undo), a nastaví sa príznak Saved.

V prípade, že sú rovnaké vždy po sebe, tak napr.:
=HYPERLINK(IF(COUNTIF(OBLAST_ODD;"KUCH")=0;"";"#A"&11+MATCH("KUCH";OBLAST_ODD;0)+COUNTIF(OBLAST_ODD;"KUCH"));"KUCH")
=HYPERTEXTOVÝ.ODKAZ(KDYŽ(COUNTIF(OBLAST_ODD;"KUCH")=0;"";"#A"&11+POZVYHLEDAT("KUCH";OBLAST_ODD;0)+COUNTIF(OBLAST_ODD;"KUCH"));"KUCH")
...
Ak nejdú po sebe tak napr. (maticový vzorec Ctrl+Shift+Enter):
=HYPERLINK(IFERROR("#A"&LARGE(IF(OBLAST_ODD="KUCH";ROW(OBLAST_ODD));1);"");"KUCH")
=HYPERTEXTOVÝ.ODKAZ(IFERROR("#A"&LARGE(KDYŽ(OBLAST_ODD="KUCH";ŘÁDEK(OBLAST_ODD));1);"");"KUCH")
...

OBLAST_ODD je Definovaný názov
='zoznam pacientov apríl'!$I$13:$I$500

Tak len z hlavy. Buď použite pri stlačení tlačítka (vypína všetky udalosti)
Application.EnableEvents = False
... vykonanie makra ...
Application.EnableEvents = True
alebo si urobte globálnu premennú v module
Public DisableActivate as Boolean
a pri stlačení použite
DisableActivate = True
... vykonanie makra ...
DisableActivate = False
pričom zároveň do Worksheet_Activate()
doplňte na začiatok
If DisableActivate Then Exit Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Name = Left$(Range("D4"), 31)
End Sub

Použil som polia, je to rýchle. Listy si rovno pomenujte vo VBA. V položke "Name" im dajte wsPoruchy a wsArchiv. Uchováva to zdrojovú tbl stále 10 riadkovú.
Sub kopiruj_a_vymaz()
Dim Radku As Long, Pocet As Long, LO As ListObject, PoleS(), PoleN(), i As Long, y As Long, x As Long, RNG As Range

Set LO = wsPoruchy.ListObjects("Tabulka38")
With LO.DataBodyRange

Pocet = WorksheetFunction.CountIf(.Columns(11), "Dokončeno") 'Zisti počet Dokončeno
If Pocet = 0 Then Exit Sub
ReDim PoleN(1 To Pocet, 1 To 11) 'Priprav veľkost poľa pre prenášané dáta podľa počtu Dokončeno
PoleS = .Value 'Načítaj dáta z Tabulka38
y = Pocet 'Index riadku od spodu

For i = 1 To UBound(PoleS, 1)
If PoleS(i, 11) = "Dokončeno" Then 'Hľadaj Dokončeno
For x = 1 To 11
PoleN(y, x) = PoleS(i, x) 'Prekopíruj dáta do nového poľa
Next x
y = y - 1 'Index o riadok vyššie
If RNG Is Nothing Then Set RNG = .Rows(i) Else Set RNG = Union(RNG, .Rows(i)) 'Pridaj do oblasti na zmazanie
End If
Next i

If Not RNG Is Nothing Then 'Ak je nejaká oblasť na zmazanie
Application.ScreenUpdating = False
If .Rows.Count - Pocet < 10 Then LO.Resize LO.Range.Resize(11 + Pocet) 'Ak bude po zmazaní menší počet riadkov v Tabulka38 ako 10, tak zväčši Tabulka38
RNG.Delete Shift:=xlUp 'Odstráň riadky

Set LO = wsArchiv.ListObjects("Tabulka2")
LO.DataBodyRange.Rows(1).Resize(Pocet).Insert 'Vlož potrebný počet riadkov do archívnej tabuľky hore
LO.DataBodyRange.Rows(1).Resize(Pocet).Value = PoleN 'Archivuj data
Application.ScreenUpdating = True
End If
End With
End Sub

Vložiť do modulu
Sub Skryt()
Dim wsSheet As Worksheet, bSkyt As Boolean

For Each wsSheet In ThisWorkbook.Worksheets
With wsSheet
bSkyt = .Columns("C:C").EntireColumn.Hidden = False
.Range("C1,AI1").EntireColumn.Hidden = bSkyt
.Range("A77,A80").EntireRow.Hidden = bSkyt
End With
Next wsSheet
End Sub

Skúste, či som to pojal správne.

Vymenil som pozíciu riadku "Rok" z riadku 3 na riadok 1, aby sa dal použiť VLOOKUP na nájdenie ceny a počtu Free Days v danom mesiaci daného roku. Tá preškrtnutá oblasť tam byť nemá (je zbytočná), ostatné musia korešpondovať s mesiacom v 6. riadku,

Zmenil som zadávanie tohto roku, teraz dáte iba do G1 prvý mesiac 1.6.2018 a ostatné sa dopočítajú.
Rovnako sa mesiac ťahá vzorcom aj do riadku 6. Aby sa zobrazilo iba to čo má, je použitý formát bunky.

Zmenil som vzorce v celej spodnej tabuľke, aj ich formát bunky, aby "--" dával formát a nie vzorec. Pre zjednodušenie pochopenia vzorcov som použil niekoľko Definovaných názvov ("CENA_V_MESICI", "DOBA_ZDARMA", "KONEC", "PLACENYCH_DNU_V_MESICI").

Ale!
Ale príde mi to nejako moc zložité. Dajte niekto niečo jednoduchšie.

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse