Stappelverarbeitung

Hallo Freunde!
Ich kämpfe schon seit Wochen (kein Profi, Selbstbeibringer halt) mit einem Problem.
Ich habe ein Sammelordner. In diesem liegen einzelne Projektordner (beliebige Anzahl, beliebige Namen). In den Projektordnern liegen dazugehörige .xlsm-Dateien (beliebige Name, id-Endung von 1 bis 5).
Sammelordner
Projekt_1
Basis1_id1.xlsm
Basis1_id2.xlsm

Projekt_2
Basis2_id1.xlsm
Basis2_id2.xlsm

Projekt_3
Basis3_id1.xlsm
Basis3_id2.xlsm

Projekt_...
Basis_...
Ich möchte In der Datei Basis1_id1.xlsm ein Button erstellen, welche mir die Zahl aus Tabelle1 und Zelle A1 ausliest und 1 dazu addiert (so, dass z.B aus Ursprungswert 1 2 wird) und A1 überschreibt. Danach sollen alle xlsm-Dateien mit Endung id1, welche im Sammelordner und Unterordern liegen nacheinander geöffnet werden, gleiche Operation durchgeführt werden (Wert in A1-Zelle), gespeichert und geschlossen werden. Ausgangsmappe Basis1_id1 bleibt offen.
Soweit mit Onkel Internet habe ich es hinbekommen, so lange der Ordner Projekt_1 außerhalb des Sammelordners liegt.
Das Ziel ist, damit Projekt_1 sich, wie auch alle anderen Projekte im Sammelordner befindet.
Wenn es der Fall ist, erhalte ich immer eine Meldung:
Userbild

Auf Ja zu drucken ist keine Option. Wenn ich auf Nein gehe bekomme ich folgende Meldung:
Userbild

Wie erreiche ich, dass Basis1_id1 nicht wieder geöffnet wird (anders gesagt übersprungen wird).
Parallel eine Frage: wie kriege ich das hin, dass nur die Files mit Endung id1 bearbeitet werden?
Hier ist mein Code:


Sub Stappelverarbeitung_von_Innen()
'Basisdokument
Range("A1").Value = Range("A1").Value + 1
'Wetere Dokumente
Const sSourcePath As String = "C:\Users\-\aL\surv-aL\9-Konfig_Baustelle\Tests\Stappelverarbeitung\"
Dim fld, file
Dim fso As Object
Dim objFld As Object
Dim objSubFld As Object
Dim objFiles As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFld = fso.getfolder(sSourcePath)
Set objSubFld = objFld.SubFolders
For Each fld In objSubFld
Set objFiles = fld.Files
For Each file In objFiles
Application.Workbooks.Open(file.Path).Activate
'Operation
ActiveWorkbook.Sheets("Tabelle1").Range("A1").Value = ActiveWorkbook.Sheets("Tabelle1").Range("A1").Value + 1
ActiveWorkbook.Close SaveChanges:=True
Next
Next
End Sub

Ich bitte Euch ganz herzlich um die Hilfe!)
Mit recht herzlichen Gruß an alle
Alex

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

For Each file In objFiles If file.Name ThisWorkbook.Name Then Application.Workbooks.Open(file.Path).Activate 'Operation ActiveWorkbook.Sheets("Tabelle1").Range("A1").Value = ActiveWorkbook.Sheets("Tabelle1").Range("A1").Value + 1 ActiveWorkbook.Close SaveChanges:=True End If Next

Sub Stappelverarbeitung_von_Innen() Const sSourcePath As String = "C:\Users\-\aL\surv-aL\9-Konfig_Baustelle\Tests\Stappelverarbeitung\" Dim fld, Name1 As String, Name2 As String Dim bolUmbenannt As Boolean Dim wbk As Workbook Dim fso As Object Dim objFld As Object Set fso = CreateObject("Scripting.FileSystemObject") Set objFld = fso.GetFolder(sSourcePath) Application.ScreenUpdating = False 'Basisdokument With ThisWorkbook.Sheets("Tabelle1").Range("A1") ' .Value = .Value + 1 wegen test auskommentiert End With For Each fld In objFld.SubFolders Name1 = Dir(fld.Path & "\*id1.xlsm") ' 'Debug.Print fld.Path 'zum testen If Name1 "" Then 'Debug.Print fld.Path & "\" & Name1 'zum testen Set wbk = Application.Workbooks.Open(fld.Path & "\" & Name1) 'datei öffnen If wbk Is Nothing Then 'wenn öffnen nicht geht weil doppelt Name2 = Replace(Name1, "_id1", "_id1xx") Name fld.Path & "\" & Name1 As fld.Path & "\" & Name2 'dann umbenennen bolUmbenannt = True Set wbk = Application.Workbooks.Open(fld.Path & "\" & Name2) 'und neu öffnen If wbk Is Nothing Then 'wenns wieder nicht geht, fehleranzeige und Ausgabe in direktfenser MsgBox "Datei kann nicht geöffnet werden" 'Debug.Print "Fehler in Datei : '" & fld.Path & "\" & Name1 & "'" ' Name fld.Path & "\" & Name2 As fld.Path & "\" & Name1 GoTo skip End If End If With wbk With .Sheets("Tabelle1").Range("A1") .Value = .Value + 1 'Debug.Print ".Value :" & .Value 'zum testen End With .Close SaveChanges:=True If bolUmbenannt Then Name fld.Path & "\" & Name2 As fld.Path & "\" & Name1: bolUmbenannt = False End With End If skip: Next End Sub

Die Fehlermeldung "Nicht genügend Arbeitsspeicher..." kam dann, als ich versuchte von der Datei "Basis1_id1" im Ordner Projekt1 den Script zu starten. Ich habe vorher nicht verstanden, dass die alle Dateien, welche in einzelnen Projektordnern liegen, von der (einzige) Datei, welche außerhalb der Projektordnern liegt, gesteuert werden soll. So funktioniert es prima!
Das ist zwar nicht so, wie ich mir von Anfang an vorgestellt habe, aber so eine Aufbau von Sammelordner und Dateien bringt unerwartet einige Vorteile im Bezug auf ganzen Projekt. Und ich kann dein Vorschlag für weitere Entwicklung ganz gut denke ich nutzen.
Echt super! Besten Dank, und wie ich schon sagte, ich bin tief beeindruckt!
P.S. Es wäre trotzdem interessand, ob es möglich ist, direkt von einer aus Dateien in belibigem Projektordner zu steuern ohne extra Datei außerhalb der Projektordnern.

dim wb as workbook for each wb in Application.Workbooks if wb.Name = Dateiname then Exit for Next If wb is nothing then hier der Code, der laufen muss wenn die Datei nicht geöffnet ist Else hier der Code für den Fall, dass die Datei bereits geöffnet ist End if

Sub Stappelverarbeitung_von_Innen_2() Const sSourcePath As String = "C:\Users\-\aL\surv-aL\9-Konfig_Baustelle\Tests\Stappelverarbeitung\" Dim fld, file Dim fso As Object Dim objFld As Object Dim objSubFld As Object Dim objFiles As Object Set fso = CreateObject("Scripting.FileSystemObject") Set objFld = fso.getfolder(sSourcePath) Set objSubFld = objFld.SubFolders For Each fld In objSubFld Set objFiles = fld.Files For Each file In objFiles Dim wb As Workbook Dim Dateiname As String Dateiname = ThisWorkbook.Name For Each wb In Application.Workbooks If wb.Name = Dateiname Then Exit For Next If wb Is Nothing Then 'hier der Code, der laufen muss wenn die Datei nicht geöffnet ist Application.wb.Open(file.Path).Activate 'Operation wb.Sheets("Tabelle1").Range("A1").Value = wb.Sheets("Tabelle1").Range("A1").Value + 1 wb.Close SaveChanges:=True Else 'hier der Code für den Fall, dass die Datei bereits geöffnet ist ThisWorkbook.Range("A1").Value = Range("A1").Value + 1 End If Next Next End Sub

Beliebteste Forumthreads (12 Monate)

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread