< návrat zpět

MS Excel


Téma: Aktualizace propojení všech souborů ve složce rss

Zaslal/a 28.2.2015 13:15

Ahoj,

prosím o radu, potřeboval bych vytvořit makro, které by mi aktualizovalo propojení ve všech souborech ve složce (včetně podsložek).
Složky obsahují pouze soubory *.xlsm.
Adresa složky je pořád stejná.

Tzn. Otevři soubor, aktualizuj všechna propojení, ulož, zavři, další soubor... a takto všechny soubory.

Jednou za čas takto potřebuji aktualizovat hodnoty ve všech sešitech, budu používat tedy poměrně často.
Děkuji za pomoc.

Zaslat odpověď >

#023926
avatar
A to je jedno v jakém pořadí se ty soubory budou aktualizovat?
Aby nedošlo k chybným výsledkům!citovat
#023927
avatar
Pořadí je jedno, nejsou na sobě závislé.
Aktualizují se ze souboru, který není v tomto adresáři ani podadresáři.citovat
#023928
avatar
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.citovat
icon #023929
eLCHa
@kp57
Mno já nevím. Jsem bez excelu, je půlnoc, navíc sobota. Takže ted́ tu nic dávat nebudu. Ale řešit tohle pomocí dávkového souboru?
Není jednodušší prostě všechny soubory otevřít (Dir + Open) včetně zdroje (pokud jsem pochopil, je jeden), překalkulovat a zavřít?citovat
#023930
avatar
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.citovat
#023931
Hav-Ran
Ja osobe by som pustil záznamník makra a predviedol raz ručne.citovat
#023932
avatar
Zdrojové soubory jsou 2.
Kdyby makro bylo pouze na jeden adresář, bylo by to jednodušší?
Udělal bych si soubor, kde bych si dal tři makra (podadresáře jsou tři) na každý adresář zvlášť bych si upravil cestu a spustil makro zvlášť.

Pokud by bylo potřeba ještě něco upřesnit, ptejte se... :-)

Děkuji za váš čas.citovat
#023936
avatar
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.citovat
icon #023942
eLCHa
@kp57
Tak tedy na popud eLCHa ještě jeden.

A ten první nefachčí, nebo co? Mně se teda líbí.


Pokud ten můj půlnoční výkřik ze tmy vyzněl jako kritika, tak to nebyl záměr. Pokud ten kód dělá to co má, tak je to v pořádku. A pokud se Vám navíc líbí, co více si přát? ;)))

Přišlo mi zbytečné vytvářet dávku a tak jsem na to upozornil.
Váš následující kód je zhruba to, co bych napsal já, jen je tam na můj vkus moc proměnných. A určitě bych tam nedával DoEvents (proč tam je? proč pouštět další události do běhu kódu?)
Vlastně jsem to zkusil napsat téměř úplně bez proměnných - ale pokud jsem chtěl použít fci Dir, tak to neprošlo. Musím načíst seznam adresářů. Ale je to úloha, u které lze využít proceduru, která volá sama sebe.
Jen pro ukázku - výpis souborů pdf včetně podsložek - na tom jsem to testoval. Aby vyhovělo zadání, už bych jen změnil typ souboru, v první proceduře otevřel ty dva zdroje a místo Debug.Print ve druhé bych dal - Open, Save, Close.Sub subListFiles()
Call subCreateList("V:\TISKY PDF\SAP", ".pdf")
End Sub

Sub subCreateList(ByVal sFolder As String, ByVal sFileType As String)
sFolder = sFolder & IIf(Right(sFolder, 1) = "\", vbNullString, "\")

Dim sFolders() As String
ReDim sFolders(0)

Dim vVal As Variant
vVal = Dir(sFolder, vbDirectory)

While Not vVal = vbNullString
If Not vVal Like ".*" Then
If GetAttr(sFolder & vVal) = vbDirectory Then
If Not sFolders(0) = vbNullString Then
ReDim Preserve sFolders(UBound(sFolders) + 1)
End If
sFolders(UBound(sFolders)) = sFolder & vVal
Else
If vVal Like "*" & sFileType Then
Debug.Print sFolder & vVal
End If
End If
End If
vVal = Dir
Wend

If Not sFolders(0) = vbNullString Then
For Each vVal In sFolders
Call subCreateList(vVal, sFileType)
Next vVal
End If
End Sub
citovat
#023953
avatar
@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".citovat

Uživatelské menu

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

Menu

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.

On-line nástroje