Příspěvky uživatele
< návrat zpět
No nič, tak dám aspoň príklad...
Situácia bude podľa mňa riešiteľná chvíľku nato ako priložíte prílohu, nech si ju nemusíme vytvárať 
Áno, ale aj tak musíte vždy vedieť čo hľadáte, lebo toto prehľadá OLE objekty (ActiveX), nenájde napr. ovál alebo klasické tlačítko, lebo to nie sú OLE.
A na novom Win je ten disk namapovaný ? Vidíte ten súbor v nejakom správcovi súborov (Prieskumník, Total Commander, ...) ? Ide Vám manuálne otvoriť ? Ak je odpoveď na všetko "áno", priložte makro.
Pre celý zošit:
Sub ChangesComboBoxesSettingBook()
Dim OLEObj As OLEObject, WS As Worksheet
Const CBID As String = "Forms.ComboBox.1"
For Each WS In ThisWorkbook.Worksheets
For Each OLEObj In WS.OLEObjects
If OLEObj.progID = CBID Then OLEObj.Object.Text = "pokus"
Next OLEObj
Next WS
End Sub
Pre jeden list:
Sub ChangesComboBoxesSettingSheet()
Dim OLEObj As OLEObject
Const CBID As String = "Forms.ComboBox.1"
For Each OLEObj In Worksheets("Hárok1").OLEObjects
If OLEObj.progID = CBID Then OLEObj.Object.Text = "pokus"
Next OLEObj
End Sub
@ marjankaj: Pravda, nevšimol som si, že som zamenil - za + 
Dá sa na to použiť aj EVALUATE
Private Sub CommandButton1_Click()
Range("F3:F214").Value = Evaluate("=F3:F214+C3:C214")
End Sub
možno pre istotu aj s názvomlistu:
Private Sub CommandButton1_Click()
Range("F3:F214").Value = Evaluate("='" & Parent.Name & "'!F3:F214+'" & Parent.Name & "'!C3:C214")
End Sub
no a klasický postup cez cyklus:
Private Sub CommandButton1_Click()
Dim F(), C(), i As Long
F = Range("F3:F214").Value
C = Range("C3:C214").Value
For i = 1 To UBound(F, 1)
F(i, 1) = F(i, 1) + C(i, 1)
Next i
Range("F3:F214").Value = F
End Sub
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?
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