Macro zum kopieren bestimmter Zellen in einer Tab.

Hallo Leute!
Ich habe folgendes Problem.
Ich habe aus einer Datenbank eine Tabelle mit bis zu 3000 Positionen in dementsprechend vielen Zeilen.
In der Spalte A stehen Zahlen zwischen 0 und 100. Es kommen jedoch nicht alle Zahlen von 1 bis 100 vor.
Es können nun 20 Zeilen mit der Nummer 0 sein, 37 Zeilen mit der Nummer 7, 15 Zeilen mit der Nummer 32, usw In der Spalte F steht die Beschreibung der Position. In der Spalte M steht der dazugehörige Eurobetrag. Dieser Eurobetrag ist manchmal allerdings 0 da diese Positionen dann Überschriften sind.
Ich möchte nun mit einem Makro folgendes erreichen.
Es soll mir in der Spalte AA alle Werte aus der Spalte F untereinander eintragen, welche die gleiche Zahl aus der Spalte A besitzen und die Werte in der Spalte M NICHT 0 sind.
In die Spalte AB soll es mir dann untereinander die nächst höhere Zahl aus Spalte A dastehen und die Werte in der Spalte M wieder NICHT 0 sind.
Also in etwa so: (Die Nummern sollten aber durch die Beschreibung aus der Spalte F ersetzt werden)
AA AB AC AD
0 7 32 48
0 7 32 48
0 7 32 48
0 7 32
0 7 32
0 7
0 7
0
0
Das Makro sollte am besten automatisch ausgeführt werden wenn ich das Tabellenblatt verlasse oder wenn ich ein bestimmtes Tabellenblatt anklicke.
Danke schon jetzt für eure Hilfe.
lg
Martin

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Martin,
hier mein Lösungsvorschlag.
Die Prozedur "DatenAufbereiten" fügst du im VBA-Editor in einem allgemeinen Modul ein;
die Activate- oder die Deactivate-Prozedur unter dem entsprechenden Tabellenblatt.
Gruß
Franz


Private Sub Worksheet_Activate()
Call DatenAufbereiten(Worksheets("Tab1")) 'Namen des Tabellenblatts ggf. anpassen
End Sub
Private Sub Worksheet_Deactivate()
Call DatenAufbereiten(Me)
End Sub
Sub DatenAufbereiten(wks As Worksheet)
'wks = Worksheet in dem Aktion ausgeführt werden soll
Dim Zeile As Long, Spalte As Integer, Spalte1 As Integer, rngTitel As Range
Application.ScreenUpdating = False
Spalte1 = 27 'Spalte AA, Spalte ab der Daten eingefügtb werden sollen
Zeile = 1 '1. auszuwertende Zeile
With wks
Set rngTitel = .Cells(1, Spalte1)
'ggf. vorhanden Daten ab Spalte AA löschen
If Not IsEmpty(rngTitel) Then
.Range(rngTitel, .Cells(1, .Columns.Count).End(xlToLeft)).EntireColumn.ClearContents
End If
rngTitel.Value = .Cells(Zeile, 1)
For Zeile = Zeile To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(Zeile, 13).Value  0 Then
'Prüfen ob Nr aus Spalte A bereits im Titelbereich vorhanden
Set Zelle = rngTitel.Find(what:=.Cells(Zeile, 1).Value, LookIn:=xlValues, _
lookat:=xlWhole)
If Zelle Is Nothing Then
'neuer Eintrag
Spalte = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
Set rngTitel = .Range(.Cells(1, Spalte1), .Cells(1, Spalte))
.Cells(1, Spalte).Value = .Cells(Zeile, 1).Value
Else
Spalte = Zelle.Column
End If
.Cells(.Rows.Count, Spalte).End(xlUp).Offset(1, 0).Value = _
.Cells(Zeile, 6).Value
End If
Next
'Spalten nach 1. Zeile Sortieren
rngTitel.EntireColumn.Sort Key1:=rngTitel.Range("A1"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=xlSortColumns, Orientation:=xlLeftToRight
'Titelzeile löschen
rngTitel.Delete Shift:=xlShiftUp
Application.ScreenUpdating = True
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Macro zum kopieren bestimmter Zellen in einer Tab.

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Macro zum kopieren bestimmter Zellen in einer Tab.

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread