Příspěvky uživatele

Tak skúste toto:
Sub UpravitData()
Dim Radku As Long, D(), i As Long, ColReg As New Collection, DatumID() As Long, PocetDatum As Long, Poradi As Long, Mazat, Sesit As String, List As String, rngMazat As Range

With ThisWorkbook
Sesit = .Name
With .ActiveSheet
Radku = .Cells(Rows.Count, 5).End(xlUp).Row - 1 'Počet riadkov podľa E
If Radku = 0 Then MsgBox "Žádná data", vbExclamation: Exit Sub
List = .Name
Mazat = Evaluate("=IF((COUNTIF(OFFSET('[" & Sesit & "]" & List & "'!A1:U1,ROW(1:" & Radku & "),),""<>"")<2)*('[" & Sesit & "]" & List & "'!E2:E" & Radku + 1 & "<>""""),TRUE,FALSE)") 'Zistiť, ktoré mazať
ReDim D(1 To Radku, 1 To 21)
D = .Cells(2, 1).Resize(Radku, 21).Value 'Načítať data do poľa

On Error Resume Next
For i = 1 To Radku
If Mazat(i, 1) Then 'Ak mazať riadok, pridať ho na zmazanie
If rngMazat Is Nothing Then Set rngMazat = .Cells(i + 1, 1) Else Set rngMazat = Union(rngMazat, .Cells(i + 1, 1))
End If

Poradi = ColReg(CStr(D(i, 4))) 'Zistiž poradie v kolekcii registračných čísel
If Err.Number <> 0 Then 'Ak ešte nieje v kolekcii, doplň ho, a ulož pozíciu dátumu
Err.Clear
PocetDatum = PocetDatum + 1
Poradi = PocetDatum
ColReg.Add Poradi, CStr(D(i, 4))
ReDim Preserve DatumID(1 To PocetDatum)
DatumID(PocetDatum) = i
Else
If D(i, 21) > D(DatumID(Poradi), 21) Then DatumID(Poradi) = i 'Ak v kolekcii je, porovnaj predošlý a aktuálny riadok dátumu, novší index ulož
End If
Next i
On Error GoTo 0

For i = 1 To Radku 'Upraviť údaje podľa najnonších dátumov
Poradi = DatumID(ColReg(CStr(D(i, 4))))
If IsEmpty(D(i, 12)) Then D(i, 12) = D(Poradi, 12)
If IsEmpty(D(i, 15)) Then D(i, 15) = D(Poradi, 15)
If IsEmpty(D(i, 16)) Then D(i, 16) = D(Poradi, 16)
If IsEmpty(D(i, 17)) Or D(i, 17) = "-" Then D(i, 17) = D(Poradi, 17)
If IsEmpty(D(i, 18)) Or D(i, 18) = "-" Then D(i, 18) = D(Poradi, 18)
If IsEmpty(D(i, 19)) Or D(i, 19) = "-" Then D(i, 19) = D(Poradi, 19)
If IsEmpty(D(i, 20)) Or D(i, 20) = "-" Then D(i, 20) = D(Poradi, 20)
Next i

.Cells(2, 1).Resize(Radku, 21).Value = D 'Vrátiť do listu upravené údaje
End With
End With

If Not rngMazat Is Nothing Then rngMazat.EntireRow.Delete 'Vymazať riadky
End Sub

Uvidíme, ako to presne myslíte, a čo chcete so súbormi robiť, koľko ich je atď ... atď. Nechce sa mi to zbytočne zdokonaľovať, keď to možno bude na nič. Pretože treba myslieť aj na zatvorenie ovládaného zošitu ovládacím zošitom, ak je tento zatváraný, a pod...

Neviem, aký máte Excel. Riešenie bude záležať aj na stave inštalácie, aj na verzii, aj na nainštalovaných aktualizáciách, postavení Jupitera voči Slnku a pod. Proste pri metóde Copy listu, dochádza v Exceli k bugu. Dosť vážnemu, spadne celý Excel, bez možnosti odchytiť chybu (preto v kóde na tom mieste ani On Error nieje).

Ako sa to správa na aktuálnom Exceli 2019 (Verzia 1808 zostava 10730.20102) + Win 10 v.1809 (zostava 17763.134) x64 SK Pro? Nuž takto:
-Ak súbor neexistuje - vytvorí sa - OK
-Ak súbor už existuje - prepíše sa - OK
-Ak súbor existuje a je otvorený - upozorní Vás to a nič neurobí - OK
-Ak ale po zatvorení daného exportovaného súboru znovu spustíte makro, spadne celý Excel.
-Pomôže iba zatvorenie tohoto spúšťacieho zošitu, potom to už ide zase bez chyby.

Obdobný problém sa tu už riešil s Office 2016 tuším. Narýchlo som to nenašiel, ale myslím, že sme na spoľahlivé riešenie ani neprišli. Zdá sa mi, že najspoľahlivejšie to bolo pri vytvorení novej inštancie, a kopírovanie do nej.

Ak niekto na to nájde link, tak ho sem šupnite.

A teraz ešte k samotnej požiadavke. Toto Vám ale urobí zo vzorcov hodnoty. Ale nezruší napr Podmienené formátovanie a vzorce v ňom, Výberové zoznamy, ani Definované názvy. Veľmi bude záležať ako to presne máte, čo tam máte použité a pod. Ak napr. kopírujete nejakú rovnakú oblasť (rovnaká šírka, výška, formátovanie,...) Tak bude lepšie iba vkladať hodnoty do šablóny, ako toto.

Som len na mobile, ale skúste zatiaľ pred .SaveAs pridať
.ActiveSheet.UsedRange.Value = .ActiveSheet.UsedRange.Value
Keď prídem pridám Vám tam ešte odchyt prípadnej chyby...

Tak raz uvádzate "vyexportovat sešit se stejným názvem" a potom zasa "zkopírovat "sheet NESHODA"". To sú dve úplne iné veci. Tu máte na Export LISTU (nie ZOŠITU !!!):

Sub ExportujList()
Dim Cesta As String, Nazev As String, CP, i As Byte

With ThisWorkbook.Worksheets("Neshoda")
Nazev = .Range("D2")
CP = Split("D:\N - Neshody\" & Nazev, "\") 'Rozlož na podadresáre
Cesta = CP(0)

If UBound(CP) > 0 Then
For i = 1 To UBound(CP) 'Cyklus vytvorí všetky požadované podadresáre, ak ešte neexistujú
Cesta = Cesta & "\" & CP(i)
If Len(Dir(Cesta, vbDirectory)) = 0 Then MkDir Cesta
Next i
End If

Nazev = Cesta & "\" & Nazev

Application.ScreenUpdating = False
Application.DisplayAlerts = False 'Vynechá hlášku o existujúcom súbore, a prepíše ho

.Copy
With ActiveWorkbook
.ActiveSheet.Shapes("btnExportListu").Delete 'Ak sa kopíruje list so spúšťacím tlačítkom, tak sa tlačítko zmaže
.SaveAs Nazev & ".xlsx", xlOpenXMLWorkbook
.Close
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
End Sub

Ale to makro kde sa nachádza uvedený riadok je pre prípad ukladania každého listu (ešte raz - LISTU, nie zošitu). Ako chcete inak uložiť list, ako do súboru ? Vy keď chcete ukladať zošit (nie List), tak použite to prvé makro. To je na zošit. To druhé si ani nevšímajte.

Netreba to ukladať vždy pri prepnutí, ale iba ak došlo k nejakej zmene.
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not ThisWorkbook.Saved Then ThisWorkbook.Save: MsgBox "Uložené", vbInformation
End Sub

"...list uložilo..."
??? Myslíte skutočne list ? Nie náhodou zošit ?
Ak list, tak to je niečo úplne iné.
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim sName As String
If Not ThisWorkbook.Saved Then
sName = ThisWorkbook.Path & "\" & Sh.Name
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sh.Copy
With ActiveWorkbook
.SaveAs sName & ".xlsx", xlOpenXMLWorkbook
.Close
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Uložené", vbInformation
End If
End Sub

Ja to chápem takto nejak. Udržuje si to dáta v DBliste, a prepínate si roky a týždne aké chcete. Tlačítko na pridávanie ďalších súborov do DB, tlačítko na zmazanie DB, úprava rozsahu rokov a týždňov (nepočítam z možnosťou že týždne chýbajú, dovolí chýbajúce navoliť, no nič nezobrazí), .... Zmenil som Vám všetky formáty, lebo ak chcete zobraziť % s medzerou pred znakom %, musí sa tam dať pevná medzera (Alt+0160), všade vzorce ťahajúce dáta z DB podľa navoleného roku a týždňa.
ALE !!!
Netuším ako urobiť, aby sa nebili voľby rok+týždeň (sú na seba viazané), ale kontru im robí voľba mesiaca. To predsa koliduje, keď si môžete navoliť 45 týždeň roku a zároveň február.

No úplne na koniec som si dofrasa všimol, že tam máte nejaký skrytý C:C, v ktorom sú odkazy na súbory, a s tým už fakt netuším čo.

Pekný deň. Možno niečo použijete.

PS: Ešte som premýšľal urobiť Načítanie súboru ako parametrizovanú procedúru, a dalo by sa potom načítať aj viac súborov naraz. Na viac nemám teraz čas, a neviem či to vôbec môže takto byť :)

EDIT:
Ešte som zabudol zmeniť formát % v priemeroch - B26,B56,B86,B116,B146,B176. Treba tam dať
0,0 %
Tá medzera je "Pevná medzera". Teda nie medzerník, ale ľavý Alt+0160. Tak ako som to použil aj na iných percentách...

Podľa mňa stačí na to napáskovať previazané zoznamy, a aj jednoduchý človek vie, že keď to naňho kričí na červeno, je to zle :)

No a kdeže je ?

Ale týmto už končím. Uznajte sama...

Celé prekopané, keď bude niekedy čas, tak Vám možno to makro aj popíšem.

Nejde mi to stiahnuť. Píše "stránka nenalezena". Pošlite mi to mailom, alebo to dajte na GoogleDrive, či niekam inam. Uvidím, kedy na to vyjde čas, možno zajtra ...

Pr. Niektoré to ale neošetrí. Napr. "/". Považuje to potom za dátum.

EDIT:
Neviem čo vymýšľam, proste tam dajte iba overenie dát
Povoliť : Čas
Údaje: je medzi
Začiatok: 0:00:00
Čas ukončenia:
23:59:00

Teda makro má pri vykonávaní pridať 2 stĺpce ? Tie tam pred vykonaním nie sú ?
Premenná Text je zmazaná, teda sa nebude vkladať do prázdnych buniek v O:O ten text "Začiatok hod." & Chr(10) & "Koniec hod." ? A teda sa nebude ani tento text vyhľadávať a farba COLOR_KONIEC je zbytočná ?
Čo sa má do tých 2 stĺpcov dávať ?
Zachovať formátovanie ako je ? Prvý a posledný riadok nových stĺpcov dátovej časti má iné vystredenie a nemá tučné písmo, ako ostatok tabuľky. Takže asi nebude platiť "zachovať formátovanie ako je" ?
Urobil som pár úprav a vyremoval zatiaľ nejaké časti. Upresnite. A priložte lepší príklad.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje