Werte in neues Sheet kopieren wenn Bedingung erfül
19.08.2017 09:52:34
Annemarie
ich scheitere gerade an einem Makro für folgendes Problem:
Ich habe eine Datei mit mehreren Sheets, die jeweils gleich aufgebaut sind. In Zeile O steht manchmal ein Wert (Preis), ansonsten DIV/0 oder nichts. Immer wenn in Spalte O ein Wert steht, möchte ich diesen sowie außerdem den Wert aus der gleichen Zeile und Spalte D und E in ein neues Sheet kopieren, sodass sie dort in der Reihenfolge D, E, O angeordnet sind (Teilenummer, Beschreibung, Preis).
Ich habe dafür ein Makro geschrieben, dass zuerst ein neues SHeet "Output" anlegt und danach die Sheets durchlaufen soll und eben das gewünschte kopieren ausführen soll.
Das Makro läuft auch, aber leider stehen in "Output" völlig falsche Werte... Und ich weiß nicht warum :-D
Ich hatte zuerst mit Copy und Paste gearbeitet, dann stand auch etwas in "Output", allerdings nur Formeln, nicht die Werte, die ich haben wollte. Wollte dann mit PasteSpecial eben die Werte einfügen, das ergab aber eine Kollision mit dem Worksheet-Objekt. Gerade versuche ich, das Ganze über Variablen zu lösen.
Leider weiß ich gerade überhaupt nicht mehr weiter, wo mein Fehlerliegt...
Hier der Code:
Sub Copy_Cond()
Dim ws As Worksheet
Dim I As Integer
Dim S As Integer
Dim WS_Count As Integer
Dim RowCount As Integer
Dim copy_o As Double
Dim copy_e As String
Dim copy_d As Long
WS_Count = ActiveWorkbook.Worksheets.Count
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Output"
End With
For S = 1 To WS_Count
Worksheets(S).Activate
RowCount = Cells(Cells.Rows.Count, "O").End(xlUp).Row
For I = 1 To RowCount
Range("O" & I).Select
check_value = ActiveCell
If Not check_value = "#DIV/0!" Or IsEmpty(ActiveCell) Then
copy_o = ActiveCell.Range("O" & I)
Worksheets("Output").Activate
RowCount = Cells(Cells.Rows.Count, "c").End(xlUp).Row
Range("C" & RowCount + 1).Value = copy_o
Worksheets(S).Activate
Range("E" & I).Select
copy_e = ActiveCell.Range("E" & I)
Worksheets("Output").Activate
Range("B" & RowCount + 1).Value = copy_e
Worksheets(S).Activate
Range("D" & I).Select
copy_d = ActiveCell.Range("D" & I)
Worksheets("Output").Select
Range("A" & RowCount + 1).Value = copy_d
End If
Next
Next
End Sub
Die Tabelle selbst kann ich leider nicht beifügen, da sie sensible Inhalte meines Arbeitgebers enthält.
Vielen Dank für die Hilfe!
Annemarie