Příspěvky uživatele
< návrat zpět
Makrom ? Prázdne riadky nemusíte mazať, to sa urobí samé. Stačí iba uložiť súbor.
Sub Nove_data_do_DB()
Dim DA(), RA As Long, DB(), RB As Long, i As Long, rngDel As Range, ColB As New Collection, Vsetko As String, Polozka, PocetNovych As Long
With wsTabA
RA = .Cells(Rows.Count, 1).End(xlUp).Row - 2
If RA = 0 Then Exit Sub
ReDim DA(1 To RA, 1 To 5)
DA = .Cells(3, 1).Resize(RA, 5).Value2
End With
With wsTabB
RB = .Cells(Rows.Count, 1).End(xlUp).Row - 2
If RB > 0 Then
ReDim DB(1 To RB, 1 To 5)
DB = .Cells(3, 1).Resize(RB, 5).Value2
For i = 1 To RB
ColB.Add i, Join(Array(DB(i, 1), DB(i, 2), DB(i, 3), DB(i, 4), DB(i, 5)), "•")
Next i
End If
End With
Erase DB
On Error Resume Next
With wsTabA
For i = 1 To RA
Vsetko = Join(Array(DA(i, 1), DA(i, 2), DA(i, 3), DA(i, 4), DA(i, 5)), "•")
Select Case Len(Vsetko)
Case 4
If rngDel Is Nothing Then Set rngDel = .Cells(i + 2, 1).Resize(, 5) Else Set rngDel = Union(rngDel, .Cells(i + 2, 1).Resize(, 5))
Case Else
Polozka = ColB(Vsetko)
If Err.Number <> 0 Then
PocetNovych = PocetNovych + 1
ReDim Preserve DB(1 To 5, 1 To PocetNovych)
DB(1, PocetNovych) = DA(i, 1): DB(2, PocetNovych) = DA(i, 2): DB(3, PocetNovych) = DA(i, 3): DB(4, PocetNovych) = DA(i, 4): DB(5, PocetNovych) = DA(i, 5)
Err.Clear
End If
End Select
Next i
End With
On Error GoTo 0
If PocetNovych > 0 Then wsTabB.Cells(RB + 3, 1).Resize(PocetNovych, 5).Value2 = WorksheetFunction.Transpose(DB)
If Not rngDel Is Nothing Then rngDel.Delete Shift:=xlUp
End Sub
Skúšajte to výhradne na fyzickej kópii súboru !!!
No tomu práve nerozumiem, ako má makro zistiť, ktorý súbor patrí do ktorej skupiny, aby mohlo zasiahnuť a zatvoriť predošlý súbor z danej skupiny. Nejako sa musia rozlišovať.
Teda "skupina zošitov" je iba jedna jediná ? Lebo výraz "vybrať skupinu zošitov" jasne evokuje možnosť výberu z viacerých možností. Nie jednu.
Uveďte ešte toto, a uvidím, porozmýšľam nad tým...
"Otvorí sa UVOD užívateľovi na PC" - Akože "sa" ? Pri štarte akéhokoľvek Excelu "sa" automaticky má otvoriť UVOD ? Naplánovanou úlohou pri štarte PC ? Alebo "si" ho užívateľ otvorí sám ? V tom prípade to má byť "Užívateľ si otvorí UVOD na PC", to je predsa veľký rozdiel.
"kde si vyberie "skupinu zošitov"" - Teda otvorenie UVOD-u vyvolá akciu, kde nabehne nejaký formulár v ktorom si má užívateľ vybrať skupinu zošitov ?
"skupinu zošitov" - To je čo ? Adresár so súbormi rovnakého typu ? Teda treba zistiť na aké slová súbory začínajú (určujúcim znakom môže byť podčiarknik). Alebo skupina zošitov znamená už výber priamo tých začínajúcich slov (napr. "Skuska_"), ImputBox-om alebo formulárom ?
"Po výbere sa otvorí SKUSKA_*(sieť) a zatvorí UVOD" - Teda sa má po výbere skupiny sám automaticky otvoriť prvý súbor danej skupiny ? Alebo sa má niekde v skrytom liste v doplnku uchovávať aktuálny výber skupiny (alebo aj zoznam možných skupín), a čakať či si súbor z danej skupiny užívateľ otvorí sám ? Vtedy je to rovnako zle napísané ako hore - nie "sa" ale "si".
No a čo ak si užívateľ svojprávne otvorí koľko chce súborov z inej ako z vybratej skupiny ?
Ak sa/si opätovne otvorí UVOD, zatvoria sa všetky zošity doteraz otvorených skupín (lebo mohol si svojvoľne otvoriť aj X zošitov z nevybratej skupiny), a načíta sa opäť prvý zošit z novovybranej skupiny ?
Ak sa pri otvorení UVOD zistí, že prvý súbor vybranej skupiny sa nedá otvoriť, tak sa z nejakou hláškou o nedostupnosti ukončí aj tento UVOD (bez uloženia)? Rovnako aj všetky doteraz otvorené súbory zo všetkých skupín?
Ak bude umožnené užívateľovi otvoriť svojvoľne aj iné skupiny, na ich zatvorenie je potreba dopredný zoznam všetkých skupín, a všetkých súborov v nich. Ak sa jedná o zložky, dá sa urobiť zoznam súborov v nich uložených, a tie uchovať v doplnku. A potom porovnávať s otvorenými zošitmi.
A to ma určite nenapadá všetko...
Prečítal som si to asi 7x a stále som nechápal čo chcete. Na 8-mi som to možno pobral. Vy chcete toto ? :
-Pri otvorení akéhokoľvek zošitu Skuska_* sa má kontrolovať, či je otvorený súbor UVOD.xls. Ak nieje, má sa otvoriť aj ten. Teda vždy, ak je nejaký Skuska_* otvorený musí byť aj UVOD.xls otvorený.
-Ak nieje otvorený žiaden Skuska_*, zatvorí sa aj UVOD.xls (bez uloženia) ?
Myslíte riešenie cez Kutools, ktorý je iba Demo, alebo riešenie cez LOOKUP, v ktorom je v poslednom kroku natvrdo capnutá absolútna oblasť (teda absolútne nedynamická) $D$2:$D$10 ? Ak pribudne kladné vyhodnotenie ďalšej hodnoty, tak to samozrejme prestane fungovať.
Do doplnku, opakujem ešte raz, DO DOPLNKU (!), vložte do modulu Tento_zošit kód:
Private WithEvents App As Application
Private Sub App_WorkbookOpen(ByVal WB As Workbook)
Dim WBS As Workbook, MenoS As String, MenoN As String
MenoN = WB.Name
If Left$(MenoN, 7) = "Skuska_" Then
For Each WBS In App.Workbooks
MenoS = WBS.Name
If Left$(MenoS, 7) = "Skuska_" And MenoS <> MenoN Then WBS.Close False: Exit For
Next WBS
End If
End Sub
Private Sub Workbook_Open()
Set App = Application
End Sub
Doplnok, znovu opakujem DOPLNOK (!) uložte.
Zámer je taký, že sa v doplnku vytvorí premenná App, ktorá sa pri Workbook_Open toho doplnku (čo sa udeje pri akomkoľvek prvotnom otvorení Excelu, keď sa aktivujú aj iné doplnky) naplní objektom samotnej aplikácie aj s udalosťami. A potom sa kontroluje každá globálna-aplikačná udalosť App_WorkbookOpen, vznikajúca pri akomkoľvek otvorení akéhokoľvek súboru. Vtedy sa zkontroluje či ide o súbor "Skuska_*", ak áno, nájde sa prípadný otvorený predošlý "Skuska_*" a zavrie sa. Takže tak. Skúste.
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...
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články