Anwendungs- oder objektdefinierter Fehler
18.07.2007 14:29:00
Peter
Mit meinem Makro führe ich die Daten verchiedener Tabellen zusammen. Er fügt in einer immer gleichlautenden Tabelle von Dateien in einer zu definierenden Spalte (hier K) vorgängig einen Identifikationsstring ein (ein paar Stellen des jeweiligen Dateinamens).
Nachfolgende Codezeile gibt mir die im Betreff erwähnte Fehlermeldung.
WB.Worksheets(TabName).Range(Cells(1, xspalteID), Cells(lr, xspalteID)) = strAktiveDatei. Interessant ist, dass der Fehler nicht bei jeder Datei, aus der Daten zu übernehme sind, vorkommt. Keine der Dateien ist gesperrt.
Wenn ich jedoch die einzelnen Komponenten anschaue, sehe ich keinen Fehler.
Ich habe WB.Name mit Debug.Print ausgewertet, das gibt mir den Dateinamen zurück.
Wenn ich mit der Maus über TabName fahre, erhalte ich den Tabellennamen
der Range ergibt K1:K? (hier 203)
mit strAktiveDatei sollte eine String, hier "875041" in den Bereich K1:K203 geschrieben werden
Hat jemand eine Idee, was hier falsch sein könnte?
Danke für eine Rückmeldung
Peter
Hier ist noch der ganze Code:
Option Explicit
Sub Dateien()
Const TabZiel = "Daten" ' Blatt in dem die Daten ankommen sollen
Dim TabName As String
Dim strVerz As String
Dim strDatei As String, strAktiveDatei As String
Dim lngZ As Long, i As Long, lr As Long, lrZiel As Long, xSpalteNr As Long, lLäName As Long, _
xAnzahlID As Long, xspalteID As Long, xItem2 As Long
Dim WBAktiv As Workbook
Dim ShTab As Worksheet
Dim WB As Workbook
Set WBAktiv = ActiveWorkbook
Set ShTab = WBAktiv.Sheets("Dateien")
TabName = Range("CTab").Value
xSpalteNr = Range("xSpalteNr").Value
xspalteID = Range("xSpalteID").Value
xAnzahlID = Range("xAnzahlID").Value
xItem2 = Range("xitem2").Value
strVerz = ActiveWorkbook.Path & "\" 'Backslash am Ende nicht vergessen!
ShTab.Columns(1).ClearContents
WBAktiv.Sheets(TabZiel).Cells.ClearContents
Application.ScreenUpdating = False
'Verzeichnis auslesen
strDatei = Dir(strVerz & "*.xls")
'Debug.Print strDatei
Do Until strDatei = ""
If UCase(strVerz & strDatei) UCase(ActiveWorkbook.FullName) Then
lngZ = lngZ + 1
ShTab.Cells(lngZ, 1) = strDatei
End If
strDatei = Dir()
Loop
'Dateien nacheinander öffnen und Daten übertragen
For i = 1 To lngZ
Set WB = Workbooks.Open(Filename:=strVerz & ShTab.Cells(i, 1))
lr = WB.Worksheets(TabName).Cells(Rows.Count, xSpalteNr).End(xlUp).Row 'Spalte wird über _
Dropdownmenu in Worksheet abgefragt
strAktiveDatei = ActiveWorkbook.Name
lLäName = Len(strAktiveDatei)
strAktiveDatei = Left(strAktiveDatei, lLäName - 4)
strAktiveDatei = Left(strAktiveDatei, xAnzahlID)
'Wenn Spalte nicht leer dann...
If lr > 0 Then
'...Wert in Blatt [TabZiel] eintragen
lrZiel = WBAktiv.Sheets(TabZiel).Cells(Rows.Count, xSpalteNr).End(xlUp).Row + 1 ' _
Spalte wird über Dropdownmenu in Worksheet abgefragt
Select Case i
Case 1
' WB.Worksheets(TabName).Rows("1:" & lr).Copy Destination:=WBAktiv.Sheets(TabZiel).Rows( _
lrZiel)
'mit voriger Zeile würde der ganze Inhalt übertragen
WB.Worksheets(TabName).Range(Cells(1, xspalteID), Cells(lr, xspalteID)) = strAktiveDatei
WB.Worksheets(TabName).Rows("1:" & lr).Copy
With WBAktiv.Sheets(TabZiel).Rows(lrZiel - 1)
.PasteSpecial Paste:=xlValues 'Werte
'.PasteSpecial Paste:=xlFormats ' Formate
End With
Application.CutCopyMode = False
Case Else
' WB.Worksheets(TabName).Rows("2:" & lr).Copy Destination:=WBAktiv.Sheets(TabZiel).Rows( _
lrZiel)
'mit voriger Zeile würde der ganze Inhalt übertragen
'Debug.Print WB.Name
BEI NACHFOLGENDER ZEILE TAUCHT DIE FEHLERMELDUNG AUF:
WB.Worksheets(TabName).Range(Cells(1, xspalteID), Cells(lr, xspalteID)) = strAktiveDatei
WB.Worksheets(TabName).Rows(xItem2 & ":" & lr).Copy 'im Eingabebereich kann angegeben _
werden, ab welcher Zeile die Daten
'ab Datei 2 übernehmen (z.B. Kopfzeile _
nur in erster Datei, dann ab Zeile 2)
With WBAktiv.Sheets(TabZiel).Rows(lrZiel)
.PasteSpecial Paste:=xlValues 'Werte
'.PasteSpecial Paste:=xlFormats ' Formate
End With
Application.CutCopyMode = False
End Select
End If
'Mappe (ohne speichern) schließen
WB.Close False
Next i
Application.ScreenUpdating = True
End Sub