Zellen in anderes Register übertragen (2)

Forumthread: 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

AW: Zellen in anderes Register übertragen (2)

10.01.2016 21:07:02

Sepp
AW: Zellen in anderes Register übertragen (2)

10.01.2016 22:10:49

Jubeldibub

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

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

Beliebteste Forumthreads (12 Monate)

Zellen in anderes Register übertragen (2)

Forumthread: Zellen in anderes Register übertragen (2)

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread