Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1464to1468
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zellen in anderes Register übertragen u. summieren

Zellen in anderes Register übertragen u. summieren
02.01.2016 13:48:26
Jubeldibub
Hallo Leute!
Ich würde gerne in einer großen Liste diverse "Markierungen" setzen und die markierten Zellen/Zeilen dann per Buttonklick in ein Register daneben kopieren, sowie bestimmte Werte daraus automatisch summieren.
Mal als Beispiel:
Es gibt Register 1:
In Spalte A stehen untereinander zig Posten.
In Spalte B stehen dazu verschiedene Summen.
In Spalte C wird die Markierung zu den jeweiligen Zellen daneben (A und B) gesetzt (z.B. durch ein schlichtes Füllen dieser Zelle mit "X").
Alle in C markierten Zeilen sollen dann per Buttonklick in das Register 2 übertragen werden können (genauer: Die Inhalte von A und B).
Dort soll dann auch automatisch für Spalte B die Summe ausgewählten Posten gebildet werden (in der Zelle unter dem letzten Eintrag in B).
Und als weiteres Gimmick: Wenn ich den Button mehrfach klicke, soll er mir die Auswahl immer wieder in Register 2 kopieren, jedoch nicht die dort eventuell bereits bestehenden Einträge überschreiben, sondern sie in einem neuen "Block" unter den bisherigen einfügen (mit einer Zeile Abstand zum vorherigen).
Ist das so möglich? Und falls ja, wie könnte man das anstellen?
Schon mal vielen Dank! Und ein frohes Neues nachträglich :)

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zellen in anderes Register übertragen u. summieren
02.01.2016 15:21:28
Sepp
Hallo ?,
ich nehme an, dass in Zeile 1 Überschriften stehen!
Sub uebertragen()
Dim rng As Range
Dim lngNext As Long

With Worksheets("Tabelle1") 'Quelltabelle - Name anpassen!
  On Error Resume Next
  Set rng = .Range("C2:C" & .Rows.Count).SpecialCells(xlCellTypeConstants, 2)
  Err.Clear
  On Error GoTo 0
End With

With Worksheets("Tabelle2") 'Zieltabelle - Name anpassen!
  If Not rng Is Nothing Then
    If .Cells(2, 2) = "" Then
      lngNext = 2
    Else
      lngNext = Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row + 2)
    End If
    Union(rng.Offset(, -1), rng.Offset(0, -2)).Copy .Cells(lngNext, 1)
    .Cells(lngNext + rng.Count, 2) = _
      Application.Sum(.Range(.Cells(lngNext, 2), .Cells(lngNext + rng.Count - 1, 2)))
  End If
End With

Set rng = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Zellen in anderes Register übertragen
02.01.2016 17:57:49
Jubeldibub
Hi Sepp,
super! Das funktioniert schon mal klasse. So richtig nachvollziehen kann ich es aber noch nicht, dazu kenne ich mich zu wenig mit VBA aus :/
ich nehme an, dass in Zeile 1 Überschriften stehen!

Genau in der ersten Zeile stehen die Überschriften (in Tabelle1), die dann eben auch jedes Mal in Tabelle 2 übertragen werden sollen (das geschieht derzeit noch nicht).
Außerdem muss ich meine simplere Vorgabe noch etwas erweitern. Zusätzlich braucht es auch noch eine Spalte "Anzahl", die ebenfalls übertragen werden soll (die Markierung wäre dann also in Spalte D vorzunehmen). Die Summierung soll dann unter Anzahl erscheinen und im Grunde "Summe" (Spalte B) x "Anzahl" (Spalte C) aller Posten berücksichtigen.

Anzeige
AW: Zellen in anderes Register übertragen
02.01.2016 18:03:06
Sepp
Hallo ?,
mach eine Beispieldatei, aus der man erkennen kann, was du genau willst.
Gruß Sepp

AW: Zellen in anderes Register übertragen
02.01.2016 18:41:55
Jubeldibub

mach eine Beispieldatei, aus der man erkennen kann, was du genau willst.

Okay, erledigt.
https://www.herber.de/bbs/user/102533.xlsm
In Tabelle1 habe ich die Liste eingefügt, aus der die Zeilen per Buttonklick kopiert werden sollen, deren Anzahl > 0 ist (das ist dann die "Markierung"). Kopiert werden sollen bei jedem Klick zusätzlich auch die Überschriften.
Unter Tabelle2 habe ich schon mal manuell das gewünschte Ergebnis zusammengestellt, dass ich per Buttonklick (bei entsprechender Auswahl in Tabelle1) erzeugen möchte.
Vielen Dank für deine Hilfe!

Anzeige
AW: Zellen in anderes Register übertragen
02.01.2016 19:05:00
Sepp
Hallo Philip,
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub CommandButton1_Click()
Dim rng As Range, varValues() As Variant
Dim lngNext As Long, lngI As Long

With Worksheets("Tabelle1") 'Quelltabelle - Name anpassen!
  If Application.CountIf(.Columns(5), ">0") > 0 Then
    Redim varValues(1 To Application.CountIf(.Columns(5), ">0") + 1)
    varValues(1) = .Range("A1:E1")
    lngI = 2
    For Each rng In .Range("A1").CurrentRegion.Columns(5).Cells
      If IsNumeric(rng.Value) And rng.Value > 0 Then
        varValues(lngI) = rng.Offset(0, -4).Resize(, 5)
        lngI = lngI + 1
      End If
    Next
  End If
End With

With Worksheets("Tabelle2") 'Zieltabelle - Name anpassen!
  If lngI > 2 Then
    If .Cells(2, 1) = "" Then
      lngNext = 2
    Else
      lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 3)
    End If
    .Cells(lngNext, 1).Resize(UBound(varValues), 5) = _
      Application.Transpose(Application.Transpose(varValues))
    
    .Cells(lngNext + UBound(varValues), 5) = _
      Application.Sum(.Range(.Cells(lngNext + 1, 5), .Cells(lngNext + UBound(varValues) - 1, 5)))
    
    .Cells(lngNext + UBound(varValues), 5).Font.Bold = True
  End If
End With

End Sub

Gruß Sepp

Anzeige
AW: Zellen in anderes Register übertragen
02.01.2016 21:03:20
Jubeldibub
Wow, klasse! Klappt gut und ich versuche das mal nachzuvollziehen - bislang kenne ich definitiv noch zu wenig VB. Heiße übrigens Markus ^^
Eine Frage zu deinem Code: Derzeit wird die Summe der Spalte E ("Sum. (ges)") als Wert in die Zelle geschrieben. Ich vermute das geschieht hier?
 Application.Sum(.Range(.Cells(lngNext + 1, 5), .Cells(lngNext + UBound(varValues) - 1, 5)))

Würde es auch gehen, dass man in diese Zelle nicht den fixen Summenwert, sondern die Summenformel einstellt? So dass sich die Summe automatisch korrigiert, wenn man in Tabelle 2 noch etwas an den Werten (Anzahl, Mult etc.) ändert.

Anzeige
AW: Zellen in anderes Register übertragen
02.01.2016 21:18:36
Sepp
Hallo Markus,
dann ist ein etwas andere Code nötig.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub CommandButton1_Click()
Dim rng As Range, rngC As Range, rngH As Range
Dim lngNext As Long, lngI As Long

With Worksheets("Tabelle1") 'Quelltabelle - Name anpassen!
  If Application.CountIf(.Columns(5), ">0") > 0 Then
    Set rngH = .Range("A1:E1")
    For Each rng In .Range("A1").CurrentRegion.Columns(5).Cells
      If IsNumeric(rng.Value) And rng.Value > 0 Then
        lngI = lngI + 1
        If rngC Is Nothing Then
          Set rngC = rng.Offset(, -4).Resize(1, 5)
        Else
          Set rngC = Union(rngC, rng.Offset(, -4).Resize(1, 5))
        End If
      End If
    Next
  End If
End With

With Worksheets("Tabelle2") 'Zieltabelle - Name anpassen!
  If Not rngC Is Nothing Then
    If .Cells(2, 1) = "" Then
      lngNext = 2
    Else
      lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 3)
    End If
    
    rngH.Copy .Cells(lngNext, 1)
    
    rngC.Copy
    
    .Cells(lngNext + 1, 1).PasteSpecial xlPasteAll
    
    .Cells(lngNext + lngI + 1, 5).FormulaR1C1 = "=SUM(R[-" & lngI & "]C:R[-1]C)"
    
    .Cells(lngNext + lngI + 1, 5).Font.Bold = True
  End If
End With

Application.CutCopyMode = False

Set rng = Nothing
Set rngC = Nothing
Set rngH = Nothing
End Sub

Gruß Sepp

Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige