AW: Gerne u. Danke für die Rückmeldung. o.w.T.
02.11.2018 08:42:10
parza
Hallo Werner, hallo Fachleute,
danke nochmals für eure große Unterstützung gestern. Ich habe nun den Code in die Originaldatei eingefügt. Unterschied sind Dateinamen und Dateipfad (ist unerheblich und funktioniert). Eine große Änderung ist, dass es im Original mehr Spalten = Arrays sind.
Nun zum Problem und was ich durch Versuch/Irrtum herausgefunden habe:
Lasse ich den Code "For intI = 0 To 4" so wie im Originalcode von Werner, läuft alles durch, allerdings werden nur 5 Spalten kopiert und eingefügt.
Ändere ich "For intI = 0 To 20" kommt ein Debugging (gelb markiert) mit Laufzeitfehler 9 bei diesen Zeilen
.Range(.Cells(3, Spalte(intI)), .Cells(.Cells(.Rows.Count, _
Spalte(intI)).End(xlUp).Row, Spalte(intI))).Copy
Beende ich nun das Debuggen, ist trotzdem alles an der richtigen Stelle und komplett eingefügt und kopiert.
Hat noch jemand eine Idee?
parza
Option Explicit
Sub KE_erstellen()
Dim intI As Integer, loZeileZiel As Long, loSpalteZiel As Long
Dim wbZiel As Workbook, wsZiel As Worksheet, Spalte As Variant
'festlegen der Zielzeile
loZeileZiel = 3
'festlegen der Zielspalte (Startspalte) A=1, B=2 ...
loSpalteZiel = 3
Spalte = Array(10, 11, 16, 17, 23, 24, 25, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 43)
Application.ScreenUpdating = False
'Datei öffnen und Zielblatt zuweisen
Set wbZiel = Workbooks.Open("Q:\4\41\AllgemeinesSG41\Zusammenarbeit\Kostenersatz\18_19\xxxx _
KE_18_19.xls")
Set wsZiel = wbZiel.Worksheets("Tabelle1")
For intI = 0 To 20
With ThisWorkbook.Worksheets("Personal")
'Bereich kopieren
.Range(.Cells(3, Spalte(intI)), .Cells(.Cells(.Rows.Count, _
Spalte(intI)).End(xlUp).Row, Spalte(intI))).Copy
With wsZiel
'kopierte Daten als Werte einfügen
.Cells(loZeileZiel, loSpalteZiel).PasteSpecial Paste:=xlPasteValues
loSpalteZiel = loSpalteZiel + 1
End With
End With
Next
'Zielblatt speichern und schließen
'wbZiel.Close True
'Kopierspeicher leeren
Application.CutCopyMode = False
'Variablen aufräumen
Set wbZiel = Nothing: Set wsZiel = Nothing
End Sub