While Schleife, Fehler~
21.12.2016 14:06:24
Marsl
habe eine While Schleife, die mir bisher immer ganz brav von ca. 80 Dateien die Daten in eine große Übersicht kopiert hat. Basis für die Anordnung der Daten ist eine Identifikationsnummer 1 ID Nummer = 1 Spalte.
Die Identifikationsnummer steht in D2 auf Datei X_Zettel
Der Bereich D5 bis DX wird kopiert und in die Übersichtsdatei kopiert (früher war dies E5 bis EX).
In dieser stehen die 80 verschiedenen Identifikationsnummern in D4 - CY4 sollte flexibel erweiterbar sein.
Ich hatte jetzt in der Quelldatei eine Spalte entfernt und bekomme es nicht hin die While Schleife entsprechend anzupassen.
Ich weiß jetzt gerade auch nicht mehr wirklich ob ich in der Zieldatei auch etwas geändert habe, der Einfügebereich in der Zieldatei beginnt in D8:D88 und geht bis CY8:CY88
Kann mir jemand helfen?
Ich denke der Fehler liegt an der While Schleife, da die Cells(zeile, spalte) sich ja ändern. Ich raff nur nicht wirklich die Ausdrücke, bzw. Ansagen die man in dieser While Schleife macht...
Set rSuch = .Range(.Cells(4, 6), .Cells(4, .Columns.Count).End(xlToLeft))
Sp = Application.Match(ID, rSuch, 0)
If Not IsError(Sp) Then
With WsQ
.Range("E5:E" & .Cells(.Rows.Count, 5).End(xlUp).Row).Copy
End With
.Cells(8, Sp + 5).PasteSpecial xlPasteValuesAndNumberFormats
Das alte Makro schaut im Ganzen so aus, meine angepasst Version erspare ich euch / mir jetzt _
lieber, da sie ja nicht funzt~ :
Sub SpaltenHolen()
Const R_ID$ = "E2"
Const PFAD$ = "M:Test"
Dim WbZ As Workbook
Dim WsZ As Worksheet
Dim WbQ As Workbook
Dim WsQ As Worksheet
Dim rSuch As Range
Dim Datei$, Sp, ID
Application.ScreenUpdating = False
Set WbZ = ThisWorkbook
Set WsZ = WbZ.Worksheets(1)
Datei = Dir(PFAD)
If Len(Datei) = 0 Then
MsgBox "Keine Dateieien gefunden in: " & PFAD, vbInformation, "Hinweis"
Exit Sub
End If
Do While Len(Datei) > 0
Set WbQ = Workbooks.Open(PFAD & Datei)
Set WsQ = WbQ.Worksheets(1)
ID = WsQ.Range(R_ID).Value
With WsZ
Set rSuch = .Range(.Cells(4, 6), .Cells(4, .Columns.Count).End(xlToLeft))
Sp = Application.Match(ID, rSuch, 0)
If Not IsError(Sp) Then
With WsQ
.Range("E5:E" & .Cells(.Rows.Count, 5).End(xlUp).Row).Copy
End With
.Cells(8, Sp + 5).PasteSpecial xlPasteValuesAndNumberFormats
End If
End With
WbQ.Close False
Datei = Dir
Loop
Application.ScreenUpdating = True
Set WbZ = Nothing
Set WsZ = Nothing
Set WbQ = Nothing
Set WsQ = Nothing
Set rSuch = Nothing
End Sub