Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1468to1472
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
Zellen in anderes Register übertragen (2)
10.01.2016 19:32:32
Jubeldibub
Hallo!
Vorab - ich hatte das Thema hier schon einmal angesprochen: https://www.herber.de/forum/archiv/1464to1468/t1466700.htm
Die dortige Lösung von Sepp funktioniert(e) hervorragend, vielen Dank schon mal dafür! Leider weiß ich nicht, ob bzw. wie ich eine Beitragsreihe im Archiv "wiederbelebe", daher habe ich ein neues Thema eröffnet.
Meine "Quellliste" hat sich mittlerweile leicht verändert, so dass der Code von Sepp so nicht mehr richtig funktioniert. Geändert hat sich: Eine neue Spalte ist hinzugekommen (was die Spalte "Anzahl", an der die Übertragung gesteuert wird, verschiebt), zudem führt die "Mult"-Spalte nun Buchstaben statt Zahlen (was aber wahrscheinlich für die Übertragung irrelevant ist).
Problem ist, dass ich den Code von Sepp (noch) nicht durchschaue *facepalm* Ich hatte schon ein wenig herumprobiert, leider aber nicht den gewünschten Effekt erzielen können.
Gewünscht ist nach wie vor, dass die Zeilen mit Anzahl größer 0 per Buttonklick auf ein anderes Register übertragen und die Spalte "Sum(ges.)" summiert wird. Ich habe mal meine veränderte Ausgangsdatei angehängt, damit ihr euch ein Bild machen könnt. Wäre schön, wenn jemand zeigen würde, wie man den bestehenden Code verändern muss, damit er wieder funktioniert.
https://www.herber.de/bbs/user/102708.xlsm
Schon mal Danke :)
Gruß Markus

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zellen in anderes Register übertragen (2)
10.01.2016 21:07:02
Sepp
Hallo Markus,
schon wieder ich ;-))
' **********************************************************************
' 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(4), ">0") > 0 Then
    Set rngH = .Range("A1:E1")
    For Each rng In .Range("A1").CurrentRegion.Columns(4).Cells
      If IsNumeric(rng.Value) And rng.Value > 0 Then
        lngI = lngI + 1
        If rngC Is Nothing Then
          Set rngC = rng.Offset(, -3).Resize(1, 6)
        Else
          Set rngC = Union(rngC, rng.Offset(, -3).Resize(1, 6))
        End If
      End If
    Next
  End If
End With

With Worksheets("Tabelle2") 'Zieltabelle - Name anpassen!
  If Not rngC Is Nothing Then
    If .Cells(1, 1) = "" Then
      lngNext = 1
    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, 6).FormulaR1C1 = "=SUM(R[-" & lngI & "]C:R[-1]C)"
    
    .Cells(lngNext + lngI + 1, 6).Font.Bold = True
  End If
End With

Application.CutCopyMode = False

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

Gruß Sepp

Anzeige
AW: Zellen in anderes Register übertragen (2)
10.01.2016 22:10:49
Jubeldibub
Hi Sepp!
Das klappt sehr gut! Eine kleine Korrektur habe ich noch an deinem Code vorgenommen, damit auch die Überschrift der sechsten Spalte bei der Übertragung ankommt:
[...]
If Application.CountIf(.Columns(4), ">0") > 0 Then
Set rngH = .Range("A1:F1")
For Each rng In .Range("A1").CurrentRegion.Columns(4).Cells
[...]

Mit deinem neuen Beispiel verstehe ich auch schon etwas besser, an welcher Stelle du was machst. Vielen, vielen Dank!
Gruß Markus

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige