Macro zum kopieren bestimmter Zellen in einer Tab.

Forumthread: Macro zum kopieren bestimmter Zellen in einer Tab.

01.02.2008 11:07:00

Martin

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

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

AW: Macro zum kopieren bestimmter Zellen in einer

01.02.2008 22:33:00

fcs

AW: Macro zum kopieren bestimmter Zellen in einer

01.02.2008 22:33:00

fcs

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.

Forumthread: Macro zum kopieren bestimmter Zellen in einer Tab.

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread