Hallo Leute,
Ich sitze an diesem Code schon etwas länger und habe auch schon im Internet und in diesem Forum selbst nach Lösungen gesucht, leider, sonst würde ich diesen Thread nicht öffnen, konnte ich mir selbst nicht helfen.
An sich will ich nichts anderes machen als von einer Arbeitsmappe in einer andere Arbeitsmappe einen Spaltenvektor einen bestimmten Länge kopieren. Der Kopiervorgang selbst dürfte an sich auch funktionieren, allerdings mit der Zeile, die mir die Daten einfügen soll habe ich so meine Probleme, habe auch schon zwei verschiedene Wege versucht (beide im Code) allerdings liefert die Verwendung der ersten Zeile den Fehler „Laufzeitfehler 1004: Anwendungs- oder objektdefinierte Fehler, und die zweite Zeile den Fehler, das die beiden Bereiche nicht die selbe Größe aufweisen und daher das kopieren des selektierten Bereiches nicht möglich ist.
Der Code soll eine ganze Zeile mit mehreren Werten durchlaufen, die alle in irgendeiner Reihenfolge in der zweiten Datei stehen. Dann soll eine Bereich in der selben Spalte in der der Wert in der zweiten Datei steht kopiert werden und in die entsprechende Spalte und nach Suche der korrekten Zeile in die erste Datei eingefügt werden.
Anbei der Code:
Sub Makro1()
Dim strDate As String
Dim strVersionNo As String
Dim strDateiName As String
Dim strPfad As String
Dim c As Range
Dim d As Range
Dim e As Range
Dim f As Range
Dim x As Integer
Dim i As Integer
Dim ii As Integer
Dim bytBreak As Byte
Dim objMappe1 As Object
Dim datReportDate As Date
Set objMappe1 = ThisWorkbook
x = 19
bytBreak = 0
strDate = Application.InputBox("Datum eingeben (Format: YYYYMMTT)", Type:=2)
strVersionNo = Application.InputBox("Versionsnummer eingeben (inkl. 0)", Default:="01", Type:=2)
strDateiName = strDate & "Dateiname“ & strVersionNo & ".xls"
Application.ScreenUpdating = False
With objMappe1
datReportDate = .Worksheets("Tabelle1").Range("B1")
For Each c In .Worksheets("Tabelle2").Range("G3:AP3")
For Each d In Workbooks(strDateiName).Worksheets(1).Range("C10:M10")
If c.Value = d.Value Then
bytBreak = 1
Workbooks(strDateiName).Worksheets(1).Range(d.Column & "18:" & d.Column & "41").Copy
For Each e In .Worksheets("Tabelle2").Range("A4:A9000")
If e.Value = datReportDate Then
Versuch 1:
'.Worksheets("Tabelle2").Range(Cells(c.Column, e.Row), Cells(c.Column, (e.Row + 23))).PasteSpecial xlPasteValues
Versuch 2:
.Worksheets("Tabelle2").Range("A1").Offset(e.Row, c.Column).PasteSpecial xlPasteValues
Exit For
End If
Next e
Exit For
End If
Next d
If bytBreak = 1 Then
Exit For
End If
Next c
End With
Application.ScreenUpdating = True
End Sub
Ich hoffe, dass ich soweit alles Notwendige erklärt habe.
Schon mal vielen Dank im Voraus für die Hilfe!
Gruß
Heimdall |