Příspěvky uživatele
< návrat zpět
Pre upresnenie - uviedol som to tučným písmo minule - priložte prílohu. Musím vidieť tie odkazy a umiestnenie, nemôžem si byť istý, či myslíte to čo píšete.
"Nějak mi to nejde" - to je popis chyby ? Hodí to chybu? Kde? Na ktorom riadku? Nestiahne správny obr? Nestiahne žiadny? ... Aká verzia a bitová kópia Excelu ...
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
#End If
Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Sub downloadImages()
Dim i As Long, sURL As String, sSubor As String, sCesta As String, aUrl() As String
sCesta = "d:\Download\Obr\"
For Each Bunka In Worksheets("Hárok1").Range("G2:G11297").Cells
sURL = ""
On Error Resume Next
sURL = Bunka.Hyperlinks(1).Address
On Error GoTo 0
If sURL <> "" Then
aUrl = Split(sURL, "/")
sSubor = sCesta & aUrl(UBound(aUrl))
URLDownloadToFile 0&, sURL, sSubor, BINDF_GETNEWESTVERSION, 0&
End If
Next Bunka
End Sub
Čítanie adresy z HL odkazu by som videl možno nejak takto (deklarácia rovnaká):
Sub downloadImages()
Dim i As Long, ret As Long, sURL As String, sSubor As String, sCesta As String
Dim aR() As Boolean, RC As Long, aUrl() As String
sCesta = "d:\Download\Obr\"
With Worksheets("Hárok1")
RC = .Cells(Rows.Count, "A").End(xlUp).Row - 1
If RC = 0 Then Exit Sub
ReDim aR(1 To RC, 1 To 1)
For Each Bunka In .Cells(2, 1).Resize(RC).Cells
i = i + 1
sURL = ""
On Error Resume Next
sURL = Bunka.Hyperlinks(1).Address
On Error GoTo 0
If sURL <> "" Then
aUrl = Split(sURL, "/")
sSubor = sCesta & aUrl(UBound(aUrl))
ret = URLDownloadToFile(0&, sURL, sSubor, BINDF_GETNEWESTVERSION, 0&)
aR(i, 1) = ret = 0
End If
Next Bunka
.Cells(2, 2).Resize(RC).Value = aR
End With
End Sub
Narýchlo:
Takže Vy chcete stiahnuť obrázky z webu? Zdroj kódu
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Sub downloadImages()
Dim i As Long, ret As Long, sURL As String, sSubor As String, sCesta As String
sCesta = "d:\Download\Obr\"
With Worksheets("Hárok1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
sSubor = sCesta & Split(.Cells(i, 1).Value, "/")(UBound(Split(.Cells(i, 1).Value, "/")))
sURL = .Cells(i, 1).Value
ret = URLDownloadToFile(0&, sURL, sSubor, BINDF_GETNEWESTVERSION, 0&)
If ret = 0 Then
.Cells(i, 3) = "File successfully downloaded"
Else
.Cells(i, 3) = "Unable to download the file"
End If
Next i
End With
End Sub
Priložte prílohu s príkladom.
Váš prvý kód otvára zošit adresa.xls (tam má byť celá cesta) a do neho vloží data zo zošitu, v ktorom spúšťate makro.
Ale teraz podľa posledného kódu je náznak, že to môže byť aj opačne. Že chcete kopírovať z toho otváraného. Aj keď ten posledný kód je zlý, ak to spúšťate z modulu skopíruje data z aktívneho listu aktívneho zošitu, a to bude po otvorení predsa práve ten otvorený súbor. Pred Range chýba vlastník.
Každopádne nebudem špekulovať, čo asi chcete ako urobiť z Vašich nefunkčných kódov. Napíšte odkiaľ sa má kopírovať (súbor + list), a kam sa má kopírovať (súbor + list). Ďalej či sú oblasti rovnaké, či sú nemenné, alebo či treba zisťovať ich veľkosť (lebo v kódoch používate rôzne oblasti).
Bez skúšania od boku
Dim w As Workbook 'A
Set w = Workbooks.Open(Filename:="adresa.xls")
w.Sheets("zpian").Range("A1:AC9999").Value=ThisWorkbook.Sheets("Zpian").Range("A1:AC9999").Value
w.Close SaveChanges:=True
Set w = Nothing
Treba urobiť tieto veci:
1. Spoločné unifikované obslužné procedúry do normálneho modulu:
Sub CMD_Button_Click(ByRef cb As ComboBox) 'Vyhledání slova ze sloupce JMÉNO
Dim rng As Range, rngSource As Range, rngDest As Range, LOsource As ListObject
Set LOsource = cb.Parent.ListObjects(1) 'Načítanie 1. Tabuľky v liste, na ktorom je volacie tlačítko
Set rng = LOsource.ListColumns("jméno").DataBodyRange.Find(What:=cb.Text)
If Not rng Is Nothing Then
Set rngSource = LOsource.Range.Rows(rng.Row) 'Zdrojový riadok
Set rngDest = Worksheets("KOŠ").Cells(1, 1).End(xlDown) 'Cieľový riadok
rngDest.Offset(IIf(IsEmpty(rngDest), 0, 1), 0).Resize(, rngSource.Columns.Count).Value = rngSource.Value 'Zápis zdrojového riadku na cieľový s ošetrením posunu riadku, ak bola cieľová tabuľka iba s 1 riadkom
rngSource.Delete Shift:=xlShiftUp 'Výmaz zdrojového riadku
cb.Text = vbNullString 'Vymaže obsah ComboBox1
Set rng = Nothing: Set rngSource = Nothing: Set rngDest = Nothing: Set LOsource = Nothing
End If
End Sub
Sub CB_Refresh(ByRef cb As ComboBox) 'Znovuvyplnenie ComboBoxu pri jeho aktivácii
cb.ListFillRange = cb.Parent.Range("ZOZNAM").Address(, , , True)
End Sub
2. Samostatné definované názvy "ZOZNAM" pre List (!) nie pre Zošit.
3. V každom module listu:
Private Sub ComboBox1_GotFocus() 'Aktualizácia zoznamu ComboBox1 - Každý list má svoj definovaný názov ZOZNAM
CB_Refresh ComboBox1
End Sub
Private Sub CommandButton2_Click() 'Volanie spoločnej procedúry kliknutia
CMD_Button_Click ComboBox1
End Sub
Teda z toho vyplýva, že zmažete ZOZNAM pre Zošit. Vytvoríte rovnaký ZOZNAM ale pre jeden List. Do modulu toho listu dáte tie 2 volacie krátke procedúry. A nakoniec do normálneho modulu dáte tie 2 obslužné procedúry. Ak tento list potom duplikujete, automaticky bude fungovať, lebo si sám vytvorí vlastný ZOZNAM odkazujúci na jeho Tabuľku.
Predpoklady na fungovanie:
-listy si vytvorte nanovo z toho jedného upraveného
-objekty sa musia volať rovnako na každom liste
-daná Tabuľka musí byť ako prvá v liste (najlepšie jediná)
Private Sub ComboBox1_GotFocus()
'Aktualizácia zoznamu ComboBox1
ComboBox1.ListFillRange = Range("ZOZNAM").Address(, , , True)
End Sub
Private Sub CommandButton2_Click()
'Vyhledání slova ze sloupce JMÉNO
Dim rng As Range, rngSource As Range, rngDest As Range, LOsource As ListObject
Set LOsource = ListObjects("Tabulka1")
Set rng = LOsource.ListColumns("jméno").DataBodyRange.Find(What:=ComboBox1.Text)
If Not rng Is Nothing Then
'Zdrojový riadok
Set rngSource = LOsource.Range.Rows(rng.Row)
'Cieľový riadok
Set rngDest = Worksheets("KOŠ").Cells(1, 1).End(xlDown)
'Zápis zdrojového riadku na cieľový s ošetrením posunu riadku, ak bola cieľová tabuľka iba s 1 riadkom
rngDest.Offset(IIf(IsEmpty(rngDest), 0, 1), 0).Resize(, rngSource.Columns.Count).Value = rngSource.Value
'Výmaz zdrojového riadku
rngSource.Delete Shift:=xlShiftUp
' Vymaže obsah ComboBox1
ComboBox1 = vbNullString
Set rng = Nothing: Set rngSource = Nothing: Set rngDest = Nothing: Set LOsource = Nothing
End If
End Sub
a Definovaný názov ZOZNAM
=OFFSET(Tabulka1[jméno];;;LOOKUP(2;1/(Tabulka1[jméno]<>"");ROW(Tabulka1[jméno])-1))
=POSUN(Tabulka1[jméno];;;VYHLEDAT(2;1/(Tabulka1[jméno]<>"");ŘÁDEK(Tabulka1[jméno])-1))
Oblasti v oboch zošitoch sú rovnaké? Nie sú tam zlúčené iné bunky, alebo na iných miestach?
Skúste zameniť xlAdd za xlPasteSpecialOperationAdd.
A určite chcete hodnoty pridávať k predošlým?
Veď to A2 som Vám tam nahradil daným vzorcom. A ani pre Vás nemôže byť predsa problém si nahradiť v texte každý výskyt subtextu iným textom - teda adresu bunky vzorcom. Ak si pozriete moju poslednú prílohu tak v stĺpci AC je presne ten Váš požadovaný vzorec, ako jeden z dvoch možných variantov. Tak si len vzorec prehoďte z AC do F. Ale kopírujte iba vzorec, nie bunku.
Vidím, že v legende sa počíta s chybou (text ##### - chyba NEDOSTUPNÝ). Aj stĺpec UL. Takže aj v stĺpci MIX sa má zobraziť "#####" ak nenájde v Zpian? Alebo má byť potom bunka ="" ?
Makro na počítanie farby .... moje nervy, čo týždeň, to chce niekto spočítavať počet farieb. Na to Excel nieje stavaný. Zmena farby nespôsobí prepočet vzorcov, a teda na to ani makro nereaguje. Mám rozpracovanú celkom sľubnú metódu, ktorá by mala reagovať na zmenu farby, bez potreby niekam klikať, no zatiaľ nefunguje správne. Zmierte sa s potrebou aktualizácie počtu. Akurát asi nieje potrebné aby sa volala vo Vašom prípade makro funkcia pre každú bunku, ale iba jedna pre celý rozsah A5:A34 a pre všetky 3 farby naraz, a len do 1 bunky C35. Mám to tak urobiť?
EDIT: To s vypísaním chyby som pridal do stĺpca AC.
Makro som zmenil, Indexov farieb môžete do funkcie zadať variabilný počet. Tlačítko aktualizuje počet. Ak ste indexy farieb nepoužívali aj na niečo iné, stĺpec B nieje potrebný.
Perfiš. A aj to sa dá zjednodušiť a odmaticovieť:
=IF(ISNUMBER(A2);A2/10^(MATCH(0;MOD(A2;10^{0;1;2;3}))-1);"")
=KDYŽ(JE.ČISLO(A2);A2/10^(POZVYHLEDAT(0;MOD(A2;10^{0;1;2;3}))-1);"")
Namiesto tej 0 vo funkcii MAX tam dajte ešte obmedzenie
...
LEN(VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0))-3
...
EDIT:
Ak tomu dobre rozumiem, malo by stačiť podľa inšpirácie marjankaj aj kratšie:
=IF(ISBLANK(B5);" "; VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0)/10^(3-MAX(0;LEN(VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0)/10^3)-5)))
=KDYŽ(JE.PRÁZDNÉ(B5);" "; SVYHLEDAT(B5; Zpian!$F$6:$AC$10001;5;0)/10^(3-MAX(0;LEN(SVYHLEDAT(B5; Zpian!$F$6:$AC$10001;5;0)/10^3)-5)))
Teda pre názornosť marjankajov vzorec po úprave:
=A1/10^(3-MAX(0;LEN(A1/10^3)-5))
=A1/10^(3-MAX(0;DÉLKA(A1/10^3)-5))
opravte ma prosím ak sa mýlim.
EDIT 2:
Tak opravujem sa sám, môj predošlý vzorec je na prd, vracia zlé výsledky, ak je číslo bez núl kratšie ako 7 alebo ak je číslo s nulami kratšie ako 5.
každopádne Marjankajove riešenie funguje bezchybne. Upravené iba na 3 nuly:
=A1/10^LEN(A1)*10^MAX(LEN(A1)-3;LEN(A1/10^LEN(A1))-2)
=A1/10^DÉLKA(A1)*10^MAX(DÉLKA(A1)-3;DÉLKA(A1/10^DÉLKA(A1))-2)
Teda Váš vzorec bude
=VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0)/10^LEN(VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0))*10^MAX(LEN(VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0))-3;LEN(VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0)/10^LEN(VLOOKUP(B5; Zpian!$F$6:$AC$10001;5;0)))-2)
=SVYHLEDAT(B5; Zpian!$F$6:$AC$10001;5;0)/10^DÉLKA(SVYHLEDAT(B5; Zpian!$F$6:$AC$10001;5;0))*10^MAX(DÉLKA(SVYHLEDAT(B5; Zpian!$F$6:$AC$10001;5;0))-3;DÉLKA(SVYHLEDAT(B5; Zpian!$F$6:$AC$10001;5;0)/10^DÉLKA(SVYHLEDAT(B5; Zpian!$F$6:$AC$10001;5;0)))-2)
Končím "výskum" 
Tu je teda jedno z riešení.
OT:No vidím, že sme včera viacerí "nemali čo v noci robiť" :) Ja som pri tom zaspal. keď som sa zobudil, v bunke napísaných asi 200 písmen "C" 
Komentáre som písal v polospánku, teraz som ich ráno skontroloval, no čo som tam preklepov nasekal, evidentne som už na to nevidel. Teraz by v nich snáď mali byť už len gramatické chyby, lebo česká gramatika mi robí niekedy problém.
Maticový vzorec ? (Ctrl+Shift+Enter)
=INDEX(N1:N7&","&O1:O7;MATCH(MAX(COUNTIFS(N1:N7;N1:N7;O1:O7;O1:O7));COUNTIFS(N1:N7;N1:N7;O1:O7;O1:O7);0))
=INDEX(N1:N7&","&O1:O7;POZVYHLEDAT(MAX(COUNTIFS(N1:N7;N1:N7;O1:O7;O1:O7));COUNTIFS(N1:N7;N1:N7;O1:O7;O1:O7);0))
Poskytnite aspoň čiastočný súbor, kde budú tie 2 listy, nejakých pár vymyslených údajov. Citlivé data nepotrebujeme. Ale presné rozloženie áno. To sa bez prílohy robí veľmi zle, navyše keď ako sám vravíte, to Vaše makro nemusí byť vôbec smerodajné, čo sa týka určenia pohyblivých častí adries.
Uživatelské menu
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články