Hi Boogie,
In der Zelle B3 (B6, B9 usw. -die Größe variert) können
folgende Ausprägungen stehen: „2000“ „5000“ „1000“ oder eine
andere 4-stellige Zahl.
Ich muss nun jeweils die beiden Zeilen über der Zahl (also
Zeile1 +2 gehören zu B3, Zeile 4 + 5 gehören zu B6 usw.)
auschneiden und in ein seprate Mappe in der ECXCEL Tabelle
speichern.
Alle "2000"er sollen in die Mappe:„Renten“
Alle "5000"er sollen in die Mappe:„Fonds“
Alle "1000"er sollen in die Mappe:„Aktien“
Alle anderen sollen in dei Mappe:„Sonstige“
Dies möchte ich gerne mit einem Makro lösen, da ich das jeden
Tag machen muss und die Datenmenge recht umfangreich werden
kann. Ich hoffe, ich habe mein Problem verständlich
beschrieben.
„seprate Mappe in der ECXCEL Tabelle“ läßt mich stark zweifeln daß ich das Richtige getroffen habe was du möchtest.
Eine Exceldatei ist eine Arbeitsmappe, die Tabellenblätter enthält, ergo gibts in einer Tabelle keine Mappe.
Wenn z.b. „Renten“ keine Mappe ist sondern ein Tabellenblatt, so ändere die vier Set-Befehle wie folgt ab:
Set wsB = Thisworkbook.Worksheets(„Renten“)
Alt+F11, Einfügen–Modul, Code reinkopieren, ggfs. anpassen, Editor schließen.
Ausführen über Extras-Makro-Makros–tt–Ausführen…
Option Explicit
'
Sub tt()
Dim ZeiQ As Long, ZeiZ As Long
Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet, wsD As Worksheet
Set wsA = Workbooks("Aktien.xls").Worksheets(1)
Set wsB = Workbooks("Renten.xls").Worksheets(1)
Set wsC = Workbooks("Fonts.xls").Worksheets(1)
Set wsD = Workbooks("Sonstige.xls").Worksheets(1)
With Worksheets("Tabelle1")
For ZeiQ = 3 To .Cells(Rows.Count, 2).End(xlUp).Row Step 3
Select Case .Cells(ZeiQ, 2)
Case 1000
ZeiZ = IIf(wsA.Cells(1, 1) = "", 1, wsA.Cells(Rows.Count, 1).End(xlUp).Row + 1)
.Rows(ZeiQ - 2).Copy Destination:=wsA.Cells(ZeiZ, 1)
.Rows(ZeiQ - 1).Copy Destination:=wsA.Cells(ZeiZ + 1, 1)
Case 2000
ZeiZ = IIf(wsB.Cells(1, 1) = "", 1, wsB.Cells(Rows.Count, 1).End(xlUp).Row + 1)
.Rows(ZeiQ - 2).Copy Destination:=wsB.Cells(ZeiZ, 1)
.Rows(ZeiQ - 1).Copy Destination:=wsB.Cells(ZeiZ + 1, 1)
Case 5000
ZeiZ = IIf(wsC.Cells(1, 1) = "", 1, wsC.Cells(Rows.Count, 1).End(xlUp).Row + 1)
.Rows(ZeiQ - 2).Copy Destination:=wsC.Cells(ZeiZ, 1)
.Rows(ZeiQ - 1).Copy Destination:=wsC.Cells(ZeiZ + 1, 1)
Case Else
ZeiZ = IIf(wsD.Cells(1, 1) = "", 1, wsD.Cells(Rows.Count, 1).End(xlUp).Row + 1)
.Rows(ZeiQ - 2).Copy Destination:=wsD.Cells(ZeiZ, 1)
.Rows(ZeiQ - 1).Copy Destination:=wsD.Cells(ZeiZ + 1, 1)
End Select
Next ZeiQ
End With
End Sub
