Hallo VBA Freunde,
brauche mal wieder Hilfe.
Ich hoffe das das geht.(Excel 2000)
In Spalte D der Mustermappe stehen die Klassen Einzel. Es kommen noch jede Menge Klassen dazu. Aber es gibt nur 3 „Endbezeichnungen“:
LG frei, LG aufg., LP
Anhand dieser Endbezeichnungen sollen nun die Zeilen in 3 verschiedene
TB kopiert werden. Also, aus der Tabelle „Ergebniserfassung“ alle mit der Endbezeichnung „LG frei“ in die Tabelle „Liste LG frei“, Endbezeichnung „LG aufg.“ in „Liste LG aufg.“, „LP“ in die „Liste LP“.
Ich habe mal für jede Liste einen Button vorgesehen.(Kann aber auch
mit einem Button geschehen.)
Es sollen auch nur Werte kopiert werden.In der Tabelle
„Ergebniserfassung“ soll nichts gelöscht werden.
Bedanke mich schon mal für jede Hilfe im Voraus.
Gruß Skaletti!
Hallo,
Habe hier ein Makro was gut funktioniert.
Möchte aber nur Werte kopieren.
Gruß Skaletti!
Sub Liste\_LG\_aufg()
Dim rng As Range, rngSource As Range, rngStart As Range
Dim varInput As Variant
Dim iRow As Integer
varInput = Application.InputBox( \_
prompt:="Bitte Bezeichnung eingeben:", \_
Title:="Namen-Zeilen kopieren", \_
Default:="\*LG aufg.", \_
Left:=263, \_
Top:=169, \_
Type:=2)
If varInput = False Then Exit Sub
Set rng = ActiveSheet.Columns("A:J").Find( \_
what:=varInput, lookat:=xlWhole, LookIn:=xlValues)
If rng Is Nothing Then
Beep
MsgBox "Suchbegriff nicht gefunden!"
Exit Sub
End If
Set rngStart = rng
Set rngSource = rng.EntireRow
Do
Set rng = Cells.FindNext(After:=rng)
If rng.Address = rngStart.Address Then Exit Do
Set rngSource = Application.Union(rngSource, rng.EntireRow)
Loop
With Worksheets("Liste LG aufg.")
iRow = .Cells(Rows.Count, 1).End(xlUp).Row
If iRow = 1 Then iRow = 2 Else iRow = iRow + 3
rngSource.Copy .Cells(iRow, 1)
End With
End Sub
In Spalte D der Mustermappe stehen die Klassen Einzel. Es
kommen noch jede Menge Klassen dazu. Aber es gibt nur 3
„Endbezeichnungen“:
LG frei, LG aufg., LP
Anhand dieser Endbezeichnungen sollen nun die Zeilen in 3
verschiedene
TB kopiert werden.
Hallo Skaletti,
Option Explicit
'
Sub Makro1()
Dim ArrBlatt, A As Integer, Zei As Long
ArrBlatt = Array("Liste LG frei", "Liste LP", "Liste LG aufg.")
With Worksheets("Ergebniserfassung")
Zei = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(1, 1), .Cells(1, 10)).Copy Destination:=.Cells(Zei + 1, 1)
For A = 0 To UBound(ArrBlatt)
.Cells(Zei + 2, 4) = "\*" & Replace(ArrBlatt(A), "Liste ", "")
Worksheets(ArrBlatt(A)).Activate
Worksheets(ArrBlatt(A)).UsedRange.ClearContents
.Range(.Cells(1, 1), .Cells(Zei, 10)).AdvancedFilter Action:= \_
xlFilterCopy, CriteriaRange:=.Range(.Cells(Zei + 1, 1), .Cells(Zei + 2, 10)), \_
CopyToRange:=Range("A1"), Unique:=True
Next A
.Activate
.Range(.Cells(Zei + 1, 1), .Cells(Zei + 2, 10)).Clear
End With
End Sub
Gruß
Reinhard
Hallo Reinhard,
vielen Dank für deine Hilfe.
Funzt wie immer prima.
Danke für das fertige Makro.
Wenn ich das richtig erkannt habe ist ein Array, also ein Feld,
das Werte aufnimmt und speichert.
Gruß Skaletti!