• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

MS Excel

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

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

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

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

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

eLCHa(13.1.2014 8:55)#017218

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

Již funguje, děkuji za pomoc :-)citovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse