Příspěvky uživatele


< návrat zpět

Strana:  1 2 3 4 5 6 7 8 9   další » ... 151

Metóda SpecialCells je v prílohe tiež :)

Také ružové to nieje. A navyše sa nemá hľadať posledný riadok, ale prvá prázdna bunka. Čo je niečo úplne iné. Lenže k nájdeniu správneho riešenia je treba správne zadanie. A to tu absentuje. Kde je ukážková príloha ?

Posielam zopár modelových situácií aj s riešeniami, a upozornením na niektoré možné problémy.

Prípadne sa dá použiť ešte aj Cells(y,x).Find(...)

Dostačovať bude asi aj ten jeden vzorec

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


Strana:  1 2 3 4 5 6 7 8 9   další » ... 151

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

vytvoření seznamu

manOfmountain • 10.12. 21:08

Excel s funkci maker

Amor007 • 10.12. 14:04

Výpis dat splňující podmínku

abrakadabravole • 10.12. 12:28

Excel s funkci maker

Jiří497 • 10.12. 12:23

Vytažení data z webu - VBA

StrejdaPompo • 10.12. 9:17

Excel s funkci maker

Amor007 • 9.12. 14:22

Vytažení data z webu - VBA

betcup • 9.12. 11:28