Příspěvky uživatele

Případně, při stejném zadání:=POZVYHLEDAT(C1+(1-JE.CHYBHODN(POZVYHLEDAT(C1+MIN(ABS(C1-A1:A3));A1:A3;0))*2)*MIN(ABS(C1-A1:A3));A1:A3;0){CSE}

Ahoj, celé jsem to neštudoval, ale na ukázku jsem upravil Module3.Makro5. Snad ti napoví.

třeba:Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rdX As Long, rdY As Long, MyStr As String
rdX = Target.Rows(1).Row: rdY = Target.Rows.Count
If rdY > 1 Then
rdY = rdX + rdY - 1
MyStr = "od: " & Format(Cells(rdX, 1), "h:mm") & " do: " & Format(Cells(rdY, 1), "h:mm")
Else
MyStr = "výbìr: " & Format(Cells(rdX, 1), "h:mm")
End If
MsgBox "oblast: " & Target.Address & vbCrLf & MyStr
End Sub

Pro tento konkrétní případ např:Private Sub Test_Barev()
Dim Cht As Chart, Srs As Series, Pt As Point
Dim ArPps() As String, Pps As String, nFC As Long
Set Cht = ActiveSheet.ChartObjects(1).Chart
Set Srs = Cht.SeriesCollection(1)
nFC = 0
For Each Pt In Srs.Points
ArPps = Split(Pt.DataLabel.Caption, ";")
Select Case ArPps(0)
Case Is = "TEST-A": nFC = 14277081
Case Is = "TEST-B": nFC = 15773696
Case Is = "TEST-C": nFC = 65535
Case Is = "TEST-D": nFC = 10213316
End Select
Pt.Format.Fill.ForeColor.RGB = nFC
Next
Set Cht = Nothing: Set Srs = Nothing
End Sub
:

@eLCHa
Opravdu pěkné.Ta otázka, i když zní všelijak, byla určena tazateli.
Vašeho názoru si vždy cením a příjímám i kritiku.
"DoEvents" tam zůstal po "RefreshAll". Protože to nefachčilo, změnil jsem na "Calculate".

Tak tedy na popud eLCHa ještě jeden.Sub Aktualizace_Tip_2()
Dim WbZdroj_1 As Workbook, WbZdroj_2 As Workbook, xWB As Workbook
Dim MyZdroj_1 As String, MyZdroj_2 As String
Dim WbPath As String, WbExt As String, xFile As Byte
Dim ArrPath() As String, MyPath As String, MyStr As String
'cesty ke zdrojum ---------------------------------------- DOPLNIT !!!
'MyZdroj_1 = "C:\cesta ke zdrojum\Zdroj_1.xlsm"
'MyZdroj_2 = "C:\cesta ke zdrojum\Zdroj_2.xlsm"
'po doplneni cest tento IF muzes smazat ------------------------------
If MyZdroj_1 = vbNullString Or MyZdroj_2 = vbNullString Then Exit Sub
'start ---------------------------------------------------------------
With Application
.Calculation = xlManual
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'adresar ThisWorkbook a prvni linie podadresaru ----------------------
WbPath = ThisWorkbook.Path & "\": WbExt = "*.xlsm"
xFile = 0
MyStr = Dir(WbPath, vbDirectory)
Do Until MyStr = vbNullString
If GetAttr(WbPath & MyStr) = vbDirectory And Not MyStr = ".." Then
xFile = xFile + 1
ReDim Preserve ArrPath(1 To xFile) As String
ArrPath(xFile) = MyStr
End If
MyStr = Dir()
Loop
'otevrit zdroje ------------------------------------------------------
Workbooks.Open MyZdroj_1: Set WbZdroj_1 = ActiveWorkbook
Workbooks.Open MyZdroj_2: Set WbZdroj_2 = ActiveWorkbook
'vyhledani souboru splnujicich podminky a jejich aktualizace ---------
For xFile = 1 To UBound(ArrPath)
MyPath = WbPath & IIf(ArrPath(xFile) = ".", vbNullString, ArrPath(xFile) & "\")
MyStr = Dir(MyPath & WbExt)
Do Until MyStr = vbNullString
If Not (ThisWorkbook.Name = MyStr Or WbZdroj_1.Name = MyStr Or WbZdroj_2.Name = MyStr) Then
Workbooks.Open MyPath & MyStr: Set xWB = ActiveWorkbook
Calculate
DoEvents
xWB.Close True
End If
MyStr = Dir()
Loop
Next xFile
'konec ---------------------------------------------------------------
WbZdroj_1.Close True: Set WbZdroj_1 = Nothing
WbZdroj_2.Close True: Set WbZdroj_2 = Nothing
Set xWB = Nothing
With Application
.Calculation = xlAutomatic
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
A ten první nefachčí, nebo co? Mně se teda líbí.
Toto makro je napsáno pro sešit, který je v adresáři ve kterém chceš aktualizovat.

No nevím jak se skrz DIR dostat do podadresářů. První řada je jasná přes "vbDirectory", ale nevím kolik vnoření tam má. Neznám adresu zdroje.

Pak třeba:Sub Aktualizace_Tip()
Dim MyPath As String, MyTxt As String, MyBat As String, MyName As String, MyStr As String
Dim xWB As Workbook, xFile As Byte, rdR As Byte, MyVypis() As String
MyPath = ThisWorkbook.Path & "\"
MyTxt = MyPath & "Dir_Vypis.txt"
MyBat = MyPath & "Dej_Vypis.bat"
MyStr = "Dir " & MyPath & "*.xlsm /B /S >" & MyTxt
xFile = FreeFile
'MyBat prikazem DIR vypise do MyTxt vsechny soubory podle masky ------
Open MyBat For Output As xFile
Print #xFile, MyStr
Close xFile
Application.Wait (Now + TimeValue("0:00:01"))
Shell MyBat
Application.Wait (Now + TimeValue("0:00:01"))
'z MyTxt naplnime MyVypis() ------------------------------------------
rdR = 0
Open MyTxt For Input As xFile
Do While Not EOF(xFile)
rdR = rdR + 1
ReDim Preserve MyVypis(1 To rdR) As String
Line Input #xFile, MyVypis(rdR)
Loop
Close xFile
With Application
.Calculation = xlManual
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'postupne otevre vsechny soubory z MyVypis() a Aktualizuje -----------
For rdR = 1 To UBound(MyVypis)
MyName = MyVypis(rdR)
If Not ThisWorkbook.FullName = MyName Then
Set xWB = GetObject(MyName)
'vypnout otazku na aktualizaci ------------ pri prvnim spusteni ------
xWB.UpdateLinks = xlUpdateLinksAlways
xWB.RefreshAll
DoEvents
Windows(xWB.Name).Visible = True
xWB.Close True
End If
Next rdR
Set xWB = Nothing
'odstranit pomocne soubory -------------------------------------------
Kill MyBat: Kill MyTxt
With Application
.Calculation = xlAutomatic
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Pokud máš v názvech diakritiku, může to dělat paseku. Ale s tím už neporadím, já diakritiku v názvech nepoužívám.

A to je jedno v jakém pořadí se ty soubory budou aktualizovat?
Aby nedošlo k chybným výsledkům!

Přidej na začátku "Application.ScreenUpdating = False"
a na konci "Application.ScreenUpdating = True".

např:Sub Vymaz()
Dim rdR As Long, rdW As Long
Application.EnableEvents = False
Application.Calculation = xlManual
For rdR = 1 To Cells(Cells.Rows.Count, 2).End(xlUp).Row
For rdW = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(rdR, 2) = Cells(rdW, 1) Then Cells(rdW, 1).Delete Shift:=xlUp
Next rdW
Next rdR
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub

Ty stahované soubory jsou ve formátu JPG ?
Pak ten kód v Modulu Listu by vypadal nějak takto:
Option Explicit
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 Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("J12:J100")) Is Nothing And Target.Count = 1 Then
If IsNumeric(Target) And Len(Target) > 2 Then
Dim WebName As String, WebId As Long, MyName As String, pzcx As Long
WebId = Int(Target / 100)
WebName = "http://8.6.3.5:8080/PumpaServer/get_doc.pl?doc_id=" & WebId
MyName = Environ("temp") & "\MyFoto.jpg" 'JPG je OK?
pzcx = URLDownloadToFile(0, WebName, MyName, 0, 0)
Application.Wait (Now + TimeValue("0:00:01"))
If Not pzcx Then
Shell "RunDLL32.exe C:\Windows\System32\Shimgvw.dll,ImageView_Fullscreen " & MyName
Else
MsgBox "CHYBA " & pzcx, , "DownLoad_Image"
End If
End If
End If
End Sub

No a ten "Temp.???" soubor se nemůže smazat, dokud ho máš v prohlížeči.
Takže asi až v Modulu Sešitu při zavírání sešitu.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim MyName As String
MyName = Environ("temp") & "\MyFoto.jpg"
If Not Dir(MyName) = vbNullString Then Kill MyName
End Sub

To je odkaz na nějaký firemní server? No abych řekl pravdu, nevím o jaký souborový formát se jedná.
Nahoře píšeš, že se ti daří (až na tu nabídku) ten soubor zobrazit v prohlížeči přímo z toho odkazu. Opravdu? Mně ne.
Prvni zkus, s jedním konkrétním souborem, jestli ho ta Fce "URLDownloadToFile" vůbec stáhne.
Soubor otevři v prohlížeči, jestli je tento formát podporovaný. Pak to dosaď do toho kódu, co máš nahoře, podle mě je v pořádku.
A asi při zavírání sešitu ten "temp" odstraň.
Jinak nevím jak poradit, nemám na čem vyzkoušet.

Ahoj, takhle přímo se mi to nedaří ani načíst.
Ale když ten jpg stáhnu do PC, pak bez problému.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
Sub DownLoad_Image_2()
Dim WebName As String, MyName As String, pzcx As Long, s As String
WebName = "http://img8.rajce.idnes.cz/d0803/6/6007/6007335_7fecf8904d46fb67d2998f7ae33776aa/images/2194.jpg?ver=0"
MyName = ThisWorkbook.Path & "\" & "MyFoto.jpg"
pzcx = URLDownloadToFile(0, WebName, MyName, 0, 0)
If Not pzcx Then
Shell "RunDLL32.exe C:\Windows\System32\Shimgvw.dll,ImageView_Fullscreen " & MyName
Else
MsgBox "CHYBA " & pzcx, , "DownLoad_Image"
End If
End Sub

Ahoj, pokud se nepletu a soubory jsou v adresářové struktuře vůdči sobě neměnné, pak při překopírování těchto souborů do jiného adresáře, na jiný disk se ve vzorcích tyto cesty upraví automaticky. Ne?
Spíš mám problém s pochopením co to je "tupé kopírování, tupé přepisování", proč tam nejde nic nastavit.
Pokud se to děje makrem, tak v něm se dá vyhodnotit zda, kde a jak se má něco přepsat. Viz "FILE_EXISTS" výše.
Funkce "&$D:\$& -> najdi si to, nebaziruj furt" a jí podobné by určitě našly uplatnění.

Edit:
Jo už mi to došlo - Synchronizace složek. Tak pardon.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje