AW: mehrere offene Arbeitsmappen durchsuchen
11.10.2021 15:06:31
Piet
Hallo Oliver
probier es bitte mal mit dieser Version. Für dich ist nur das sehr kurze Hauptprogramm wichtig. Dort kannst du mit VlgBlatt alle Blätter angeben.
Der Befehl Go
Sub dahinter ruft (nicht vergessen) ein Unterprogramm auf, das die Aufgabe abarbeitet. Schau mal ob es so einwandfrei klappt?
Ich kopiere nach Find=Okay ab Zelle A5 bis zum Ende der Spalte alles in den Reiter ab der Copy Adresse in Zelle A1. Und erhöhe die Copy Adresse in A1.
mfg Piet
Sub Offene_Dateien_durchsuchen_2()
Dim rfind As Range, j, n, lz1 As Long
Dim CopyAdr As String, Test As Variant
Dim VlgBlatt As String, Suchtxt As String
VlgBlatt = "SF_LTM": Go
Sub suchen 'Unterrprogramm zum Vorlageblatt suchen und bearbeiten
VlgBlatt = "SF_xxx": Go
Sub suchen '** diese Prozedur kann beliebig oft aufgerufen werden!
VlgBlatt = "SF_yyy": Go
Sub suchen '** Es setzt voraus das der Suchwert immer in Zelle A3 steht
MsgBox n & " CSV Dateien kopiert"
Exit Sub
suchen: '*** Unterprogramm zum Vorlage Blatt bearbeiten ***
With ThisWorkbook
On Error Resume Next
Set Test = .Worksheets(VlgBlatt)
If Err > 0 Then MsgBox VlgBlatt & " dieses Vorlageblatt exisitiert nicht!": Return
Test = Empty: Err.Clear
Suchtxt = .Worksheets(VlgBlatt).[a3] 'Zelle A3
CopyAdr = .Worksheets(VlgBlatt).[a1] 'Zelle A1
'alle Offenen Dateien nach Vorlage Blatt durchsuchen
For j = 1 To Windows.Count
If InStr(Windows(j).Caption, .Name) = 0 And _
InStr(Workbooks(j).Name, VlgBlatt) Then Test = "Ok": Exit For
Next j
If Test = Empty Then MsgBox VlgBlatt & " CSV Datei nicht gefunden!": Return
'On Error GoTo Fehler
'Suchwert in CSV Datei suchen
Set rfind = Workbooks(j).Sheets(1).Columns(1).Find(What:=Suchtxt, _
After:=[a1], LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:= _
xlColumns, SearchDirection:=xlNext, MatchCase:=False)
'gefundennen Wert als Text kopieren
If Not rfind Is Nothing Then
lz1 = Workbooks(j).Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(j).Sheets(1).Range("A5:A" & lz1).Copy
.Worksheets(VlgBlatt).Range(CopyAdr).PasteSpecial xlPasteAll
Application.CutCopyMode = False
'Neue Adresse in Vorlageblatt Zelle A1 schreiben
lz1 = .Worksheets(VlgBlatt).Cells(Rows.Count, 1).End(xlUp).Row
.Worksheets(VlgBlatt).Range("A1") = "A" & lz1 + 1
n = n + 1 'Anzahl kopierter CSV Dateien
'CSV Datei schliessen ohne speichern
Workbooks(j).Close savechanges:=False
End If
Return
End With
Fehler: MsgBox "unerwarteter Fehler aufgetreten!" & vbLf & Error()
End Sub