Supportnet / Forum / Tabellenkalkulation

Hallo an Alle, da man hier schon das ein oder andere Mal sehr gut weitergeholfen hat und ich von VBA in EXCEL kaum Ahnung habe, möchte ich hier mal ein weiteres Problem posten: Ich habe ein EXCEL.-Datei die folgendermaßen aufgebaut ist:: A B C D E F G H 1 x x x x x x x x 2 x - - - - - - - 3 - y - - - - - - 4 x x x x x x x x 5 x - - - - - - - 6 - y - - - - - - 7 x x x x x x x x 8 x - - - - - - - 9 - y - - - - - - usw. 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. Vielen Dank schonmal für Eure Hilfe Grüße

Unter Extras kannst Du Makros aufzeichnen, abspeichern und sogar einen Befehl im Menü bzw. ein Icon ablegen.

Hat den Vorteil, dass man sich das VBA anschauen kann, ohne zu programmieren.

St.B.

Hallo,

ja, ich kenne die Makro-Aufzeichnung, aber in meinem Fall hilft mir das nicht weiter. Die Tabelle ist ziemlich umfangreich und ich muss ja auf jeden Fall das Makro dann anpassen.

Nein, musst Du nicht! Du musst bloß den Copybereich von vornherein so groß wählen, dass nichts übrigbleibt.

Leere Zellen zu kopieren ist ja nicht verboten.

St.B.

Sorry, aber ich versteh nicht, wie ich das mit copy und paste machen soll!
Deshalb hab ich mich ja hier ans Forum gewandt!

Ich weiß z.B. nicht, wie ich diese Bedingungen, als das "2000" in "Renten" usw. bei der Aufzeichnung eines Makros berücksichtigen kann.

Hallo

Ich wuerde vorschlagen Spalte B einem Array zu uebergeben und dieses abzufahren mit Abtastung auf die Zahlenwerte und anschliessenden Duplizierung in die entsprechende Tabelle

Gruss gast

@yast2000
Das möcht ich doch mal gerne Sehen mit der Makroaufnahme,das geht wohl eher nicht bzw ist unmoeglich

Hallo Gast,

dein Ansatz klingt nett, aber ich habe leider keine Ahnung, wie ich das programmieren kann, ich bin VBA-Laie!

Kann mir jemand weiter helfen??

hallo Sven

Tabellenname Tabelle1=Quelle
Tabellenname sonstige=rausfallende daten

1 zeile ueberschrift vorrausgesetzt

cu gast

Option Explicit
Sub Auffuellen()
Call EventsOff
Dim zaehler As Long, zeile As Long
Worksheets("Tabelle1").Select
zeile = Worksheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row
ReDim matrix(zeile, 3) As Variant
matrix() = Range(Cells(1, 2), Cells(zeile, 2))
For zaehler = 4 To zeile Step 3
If matrix(zaehler, 1) = "1000" Then
zeile = Worksheets("1000").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("1000").Rows(zeile)
End If
If matrix(zaehler, 1) = "2000" Then
zeile = Worksheets("2000").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("2000").Rows(zeile)
End If
If matrix(zaehler, 1) = "5000" Then
zeile = Worksheets("5000").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("5000").Rows(zeile)
End If
If matrix(zaehler, 1) <> "1000" And matrix(zaehler, 1) <> "2000" And matrix(zaehler, 1) <> "5000" Then
zeile = Worksheets("sonstige").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("sonstige").Rows(zeile)
End If
Next zaehler
Call EventsOn
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Hallo Gast 123,

super, das war genau das, was ich brauche. Scheint zu funktionieren. Vielen Vielen Dank.

Ein kleines Problem hab ich noch, in der Usprungs-Tabelle sind alle Zellen als Text formatiert, gibt es ein Makro, welches als Text formatierte Zahlen in Zahlen umformatiert?

Vielen Dank an alle für die Hilfe!1

So, das mit den Zahlen formatiereb hab ich ausnahmsweise selbst hinbekommen.
Vielen Dank noch mal an Alle und speziel gast123.

Grüße

hi sven

korrigierung in diesem abschnitt

aus zeile wird zeile1

gruss gast

zeile1 = Worksheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row
ReDim matrix(zeile, 3) As Variant
matrix() = Range(Cells(1, 2), Cells(zeile, 2))
For zaehler = 4 To zeile1 Step 3

hi sven

besser das ganze nochmal

gruss gast 123

Option Explicit
Sub Auffuellen()
Call EventsOff
Dim zaehler As Long, zeile As Long, zeile1 As Long
Worksheets("Tabelle1").Select
zeile1 = Worksheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row
ReDim matrix(zeile1, 3) As Variant
matrix() = Range(Cells(1, 2), Cells(zeile1, 2))
For zaehler = 4 To zeile1 Step 3
If matrix(zaehler, 1) = "1000" Then
zeile = Worksheets("1000").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("1000").Rows(zeile)
End If
If matrix(zaehler, 1) = "2000" Then
zeile = Worksheets("2000").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("2000").Rows(zeile)
End If
If matrix(zaehler, 1) = "5000" Then
zeile = Worksheets("5000").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("5000").Rows(zeile)
End If
If matrix(zaehler, 1) <> "1000" And matrix(zaehler, 1) <> "2000" And matrix(zaehler, 1) <> "5000" Then
zeile = Worksheets("sonstige").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Worksheets("Tabelle1").Rows(zaehler - 2 & ":" & zaehler - 1).Copy Worksheets("sonstige").Rows(zeile)
End If
Next zaehler
Call EventsOn
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Hallo gast 123,

bisher hat das Makro bei den Tests gut funktioniert.
Was bewirkt denn deine vorgeschlagene Änderung von "zeile" in "zeile1"?

Danke und Grüße
Sven

hi sven

die abtastung des ende der spalte b ist so nicht korrekt,sie wird durch den fehler(der jetzt korrigiert ist) verkuerzt

gruss gast123

• Tabelle Mischen:
• Wenn ein Suchkritierium in Spalte 7 übereinstimmt, soll es die Zeile in eine entsprechende Tabelle übernehmen
• CSV Export Problem Excel
• Excel per VBA automtisch speichern mit ERWEITERUNG aus anderer Tabelle
• Seitenumbrüche in Excel-sheet einfügen per VBA