< návrat zpět

MS Excel

Téma: Načtení dat z několika souborů - různá hesla rss

Zaslal/a zmetik 12.1.2014 17:04

Dobrý den,

Potřeboval bych poradit s makrem, které by mělo projít všechny soubory v určité složce (soubory mají stejnou strukturu)a natahat z nich data do řádků souhrnného souboru. Problémem je, že jednotlivé zdrojové soubory jsou zamčené různými hesly. Pomocí makra bych chtěl zadat jedno heslo a poté projít všechny soubory tak, aby se načetla data jen ze souborů, u kterých sedí zadané heslo. Makro jsem dotáhl do stavu, kdy mi načte data, pokud všechny soubory mají heslo stejné, ale zastaví se s chybou, pokud narazí na soubor s heslem odlišným a již nepokračuje. Další věcí je, že všechny úspěšně načtené soubory ze zdrojové složky by se poté měly automaticky přesunout do složky jiné, aby bylo vidět, které soubory jsou již zpracované.

Níže zasílám rozepsané makro:

Sub nacisthodnoty()
Dim souborkalkulace As String
Dim cesta As String
Dim heslo As String
Dim i As Integer
i = 2
Application.DisplayAlerts = False
Application.ScreenUpdating = False

cesta = "C:\PREvsPOST\InputPrecalc\"
souborkalkulace = Dir(cesta)
heslo = InputBox("Input the password to unprotect Calculation Tools", "Calculation Tool password")

Do While Len(souborkalkulace) > 0

Workbooks.Open (cesta & souborkalkulace), , , , heslo

Range("C11").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 1)
Range("L11").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 2)
Range("C19").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 3)
ActiveWorkbook.Close

i = i + 1
souborkalkulace = Dir
Loop

End Sub

Díky moc za všechny potenciální rady:-)

Zaslat odpověď >
kp57(12.1.2014 20:47)#017209
avatar
No ten chybový stav bych ošetřil:
On Error Resume Next
příkazy
On Error Goto 0
a ten přesun:
Name OldName As NewNamecitovat
zmetik(12.1.2014 22:00)#017211
avatar
pokud ošetřím chybový stav tak, jak navrhujete, tak mi to automaticky zavře načítací souhrnný soubor :-(citovat
kp57(12.1.2014 23:09)#017212
avatar
Sub nacisthodnoty()
Dim souborkalkulace As String, cesta As String, heslo As String, i As Integer
i = 2
Application.DisplayAlerts = False
Application.ScreenUpdating = False
cesta = "C:\PREvsPOST\InputPrecalc\"
souborkalkulace = Dir(cesta)
heslo = InputBox("Input the password to unprotect Calculation Tools", "Calculation Tool password")
On Error Resume Next
Do While Len(souborkalkulace) > 0
Workbooks.Open (cesta & souborkalkulace), , , , heslo
If Err = 0 Then
Range("C11").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 1)
Range("L11").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 2)
Range("C19").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 3)
i = i + 1
ActiveWorkbook.Close
Name cesta & souborkalkulace As NovaCesta & souborkalkulace
Else
Err = 0
End If
souborkalkulace = Dir
Loop
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Subcitovat
icon eLCHa(13.1.2014 8:55)#017218
eLCHa
Využijte proměnnou typu Workbook
Sub nacisthodnoty()
Dim souborkalkulace As String
Dim cesta As String
Dim heslo As String
Dim i As Integer
Dim w As Workbook

i = 2
Application.DisplayAlerts = False
Application.ScreenUpdating = False

cesta = "C:\PREvsPOST\InputPrecalc\"
souborkalkulace = Dir(cesta)
heslo = InputBox("Input the password to unprotect Calculation Tools", "Calculation Tool password")

Do While Len(souborkalkulace) > 0
On Error Resume Next
Set w = Workbooks.Open(Filename:=cesta & souborkalkulace, Password:=heslo)
On Error GoTo 0

If Not w Is Nothing Then
w.Sheets("XY").Range("C11").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 1)
w.Sheets("XY").Range("L11").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 2)
w.Sheets("XY").Range("C19").Copy Destination:=Workbooks("nacitaci.xlsm").Worksheets("list1").Cells(i, 3)
w.Close
Set w = Nothing

i = i + 1
souborkalkulace = Dir
End If
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
citovat
zmetik(18.1.2014 16:21)#017354
avatar
Již funguje, děkuji za pomoc :-)citovat

Uživatelské menu

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

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