SVERWEIS: Pfad dynamisch

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub alle() Dim zbk As Workbook Dim qbk As Workbook Dim datei As String Dim zsht As Worksheet ChDrive "H" Set zbk = Workbooks(ActiveWorkbook.Name) ChDir zbk.Path Set zsht = zbk.Worksheets("Tabelle2") datei = Dir(zbk.Path & "\*KB*.xls") With zsht Do While datei "" Workbooks.Open datei, False, True On Error Resume Next Worksheets("ATB").Activate If Err.Number = 0 Then ActiveSheet.Range(Cells(4, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet. _ UsedRange.Columns.Count)).Copy .Cells(.UsedRange.Rows.Count + 1, 1) End If Err.Clear ActiveWorkbook.Close False datei = Dir Loop End With End Sub

Sub Aktualisieren() Dim j%, i%, m%, k%, strDateiname$ j = Year(CDate(Range("A1"))) i = i + 1 m = i k = Range("Y1") 'Dateien öffnen For i = 1 To 12 strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & m & "\Details\" & k & "_Detail_" & m & ". _ xls" Workbooks.Open Filename:=strDateiname ActiveSheet.Calculate Next i End Sub

Sub Aktualisieren() Dim j%, i%, m%, k%, strDateiname$ j = Year(CDate(Range("A1"))) i = i + 1 m = i k = Range("Y1") 'Dateien öffnen For i = 1 To 12 strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & m & "\Details\" & k & "_Detail_" & m & ". _ _ xls" Workbooks.Open Filename:=strDateiname ActiveSheet.Calculate Next i End Sub

Sub Aktualisieren() Dim j%, i%, m%, k%, strDateiname$ j = Year(CDate(Range("A1"))) i = i + 1 m = i k = Range("Y1") 'Dateien öffnen For i = 1 To 12 debug.print "i=" & i & " / m=" & m & " / j =" & j & " / k =" & k strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & m & "\Details\" & k & "_Detail_" & m & ". _ _ xls" Workbooks.Open Filename:=strDateiname ActiveSheet.Calculate Next i End Sub

Sub Aktualisieren() Dim j%, i As Byte, m As Byte, k%, strDateiname$ j = Year(CDate(Range("A1"))) k = Range("Y1") 'Dateien öffnen On Error Resume Next For i = 1 To 12 m = m + 1 strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & m & "\Details\" & k & "_Detail_" & m & ". _ _ xls" Workbooks.Open Filename:=strDateiname Next i

Hi Marek,
dass ich nichts von Vorgang halte, Dateien öffnen / INDIREKT berechnen / Dateien schließen, sagte ich bereits. Aber da du explizit danach fragst, bitte sehr:

Sub vieleOeffnen()
Call VieleDateien(True)
End Sub
Sub vieleSchliessen()
Call VieleDateien(False)
End Sub
Sub VieleDateien(bOpen As Boolean)
Dim j%, i As Byte, k%, strDateiname$
Dim wkbOld As Workbook
j = Year(CDate(Range("A1")))
k = Range("Y1")
Set wkbOld = ActiveWorkbook
For i = 1 To 12
strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & i & "\Details\" & k & "_Detail_" & i & ". _
xls """
If bOpen Then       'Dateien öffnen oder
Call FileCheckOpen(strDateiname)
Else                'Dateien schließen
On Error Resume Next
If WkbExists(strDateiname) Then Workbooks.Close strDateiname
On Error GoTo 0
End If
Next i
'wieder ins alte Workbook wechseln (beim Datei-Öffnen geraten die neuen Workbooks in den Focus)
wkbOld.Activate
activesheet.calculate
End Sub
'*********************************************************************************************** _
'* Module to open needed files. Checks if Files are open or not.
'* If file is already open, do nothing - else open it
'* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm
'* modified by Klaus Meyer von der Twer / 16.NOV.2012
'*********************************************************************************************** _
'Example:
'Call FileCheckOpen("C:\TMP", "Filename.xls")
'path and filename can be RANGE from excelsheet
Sub FileCheckOpen(sPath As String)
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
End If
End Sub
Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function

Das "FileCheckOpen" Makro stammt aus meiner Sammlung und verhindert, dass Fehlermeldungen entstehen wenn ein Workbook (noch) nicht existiert.
Mit dem Makro Sub vieleOeffnen() öffnest du alle Dateien, mit Sub vieleSchliessen() gehen sie wieder zu.
Die Variable m habe ich raus geworfen. Du zählst schon i hoch (for i = 1 to xxx), da musst du nicht separat m hochzählen und verwenden - verwende direkt i.
Grüße,
Klaus M.vdT.

Option Explicit Sub Aktualisieren() Dim j%, i As Byte, k%, strDateiname$ Dim wkbOld As Workbook j = Year(CDate(Range("A1"))) k = Range("Y1") Set wkbOld = ActiveWorkbook 'Dateien öffnen For i = 1 To 12 strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & i & "\Details\" & k & "_Detail_" & i & ". _ xls" If WkbExists(strDateiname) Then Workbooks.Open Filename:=strDateiname Else On Error GoTo 0 Next i wkbOld.Activate ActiveSheet.Calculate For i = 1 To 12 If WkbExists(strDateiname) Then Workbooks(strDateiname).Close Else On Error GoTo 0 Next i End Sub Private Function WkbExists(strDateiname As String) As Boolean Dim wkb As Object 'On Error Resume Next Set wkb = Workbooks(strDateiname) If Not wkb Is Nothing Then WkbExists = True End If End Function

Hi Marek,
kommt in der Zeile "set wbk = ..." der Laufzeitfehler 9, Index außerhalb des gültigen Bereichs
das ist, weil du "on error resume next" ausgeklammert hast! Das ist aber ein elementarer Bestandteil dieser Function.
Wenn es ein workbook nicht gibt, wird der Variable "wkb" auch nichts zugewiesen. Durch OnError läuft die Function trotzdem weiter. Direkt danach wird gefragt, ob in der Variable wkb irgendwas steht. Wenn dort nichts steht (da die Set wkb-Zeile durch "OnError" übersprungen wurde) dann meldet die Funktion, dass es eben kein Workbook gibt.
Klammerst du das "on Error" aus, bricht die Function korrekterweise ab - sie versuchte ja, ein Workbook zu öffnen das es nicht gibt.
Dein Code kann und wird trotzdem nicht funktionieren. In der ersten FOR-NEXT schleife weist du i die Werte 1-12 zu und veränderst jedesmal den String "strDateiname".
In der zweiten Schleife fasst du den String nicht mehr an! Das heist, VBA wird 12-mal prüfen ob die letzte Gültige Datei existiert und sie gegebenenfalls schließen.
Zusammenbasteln musst du das jetzt selber, ich habe bereits eine funktionale Version geliefert :-)
Grüße,
Klaus M.vdT.

Option Explicit Sub Aktualisieren() Dim j%, i As Byte, k%, strDateiname$ Dim wkbOld As Workbook j = Year(CDate(Range("A1"))) k = Range("Y1") Set wkbOld = ActiveWorkbook 'Dateien öffnen For i = 1 To 12 strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & i & "\Details\" & k & "_Detail_" & i & ". _ xls" If WkbExists(strDateiname) Then Workbooks.Open Filename:=strDateiname Else On Error GoTo 0 Next i wkbOld.Activate ActiveSheet.Calculate 'Dateien schließen For i = 1 To 12 strDateiname = "C:\Pfad1\Pfad2\Pfad3 " & j & "\" & i & "\Details\" & k & "_Detail_" & i & ". _ xls" If WkbExists(strDateiname) Then Workbooks(strDateiname).Close Else On Error GoTo 0 Next i End Sub Private Function WkbExists(strDateiname As String) As Boolean Dim wkb As Workbooks On Error Resume Next Set wkb = Workbooks(strDateiname) If Not wkb Is Nothing Then WkbExists = True End If End Function

Beliebteste Forumthreads (12 Monate)

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread