ThisWorkbook nicht öffnen
09.10.2013 01:10:18
Erich
Hi Thomas,
das Antworten in einem bestehenden Thread klappt jetzt also - erfreulich! :-)
Schau dir den Code mal an:
Option Explicit
Sub MonatsZusammenfassung()
Dim strOrdner As String, strTagZusFass As String
Dim lngZeile As Long
Dim wksMonatZusFass As Worksheet
Dim strTagDatei As String
Dim wkbTag As Workbook, wksTAF As Worksheet
Set wksMonatZusFass = ActiveSheet 'Zieltabelle
With wksMonatZusFass
strTagZusFass = .Range("B5").Text
strOrdner = .Range("B6").Text
'Zeilen in Spalte A ab Zeile 10 abarbeiten
For lngZeile = 10 To .Cells(.Rows.Count, 1).End(xlUp).Row 'Korrektur Zeile -- lngZeile
'Prüfen, ob leer
If .Cells(lngZeile, 1) = "" Then Exit For
'Eintrag in Spalte A
strTagDatei = .Cells(lngZeile, 1).Text
'Prüfen, ob Datei vorhanden
'If .Cells(lngZeile, 1) = .Range("A1") Then GoTo weiter
'Korrektur strPfad -- strOrdner
If Dir(strOrdner & Application.PathSeparator & strTagDatei) "" Then
If UCase$(strTagDatei) = UCase$(ThisWorkbook.Name) Then
Set wkbTag = ThisWorkbook
Else
'Datei schreibgeschützt öffnen 'Korrektur strPfad -- strOrdner
Set wkbTag = Application.Workbooks.Open(Filename:=strOrdner & _
Application.PathSeparator & strTagDatei, ReadOnly:=True)
End If
'weiter:
Set wksTAF = wkbTag.Worksheets("TAF")
'Daten nach Ziel kopieren
.Cells(lngZeile, 2).Resize(4) = wksTAF.Range("C3").Resize(4).Value
' .Cells(lngZeile, 2) = wksTAF.Range("C3").Value
' .Cells(lngZeile, 3) = wksTAF.Range("C4").Value
' .Cells(lngZeile, 4) = wksTAF.Range("C5").Value
' .Cells(lngZeile, 5) = wksTAF.Range("C6").Value
.Cells(lngZeile, 6) = wksTAF.Range("e3").Value
.Cells(lngZeile, 7) = wksTAF.Range("e4").Value
.Cells(lngZeile, 8) = wksTAF.Range("e7").Value
.Cells(lngZeile, 9) = wksTAF.Range("e5").Value
.Cells(lngZeile, 10) = wksTAF.Range("e6").Value
.Cells(lngZeile, 11).Resize(5) = wksTAF.Range("h3").Resize(5).Value
' .Cells(lngZeile, 11) = wksTAF.Range("h3").Value
' .Cells(lngZeile, 12) = wksTAF.Range("h4").Value
' .Cells(lngZeile, 13) = wksTAF.Range("h5").Value
' .Cells(lngZeile, 14) = wksTAF.Range("h6").Value
' .Cells(lngZeile, 15) = wksTAF.Range("h7").Value
If UCase$(strTagDatei) UCase$(ThisWorkbook.Name) Then _
wkbTag.Close savechanges:=False 'Tages-Datei wieder schliessen
End If
Next
End With
End Sub
Noch ein Tipp:
Wenn die Zeilen (incl. der Kommentare) nicht so lang sind, muss die Forumssoftware keine Umbrüche einfügen,
der Code wird dann schöner dargestellt.
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich