Thema Datum  Von Nutzer Rating
Antwort
20.06.2019 22:19:29 Elena
NotSolved
20.06.2019 22:31:54 Gast10703
NotSolved
20.06.2019 23:41:30 Mackie
NotSolved
21.06.2019 10:36:02 Elena
NotSolved
21.06.2019 17:56:05 Gast94764
NotSolved
22.06.2019 08:12:09 Elena
NotSolved
Rot Makro zur Zusammenfassung mehrerer Zeilen // Terminserie
22.06.2019 15:31:36 Gast94764
NotSolved
24.06.2019 10:14:39 Elena
NotSolved
24.06.2019 13:15:45 Elena
NotSolved
24.06.2019 13:15:54 Elena
NotSolved
24.06.2019 15:39:11 Gast94764
NotSolved
24.06.2019 23:33:37 Elena
NotSolved
21.06.2019 20:26:54 Gast86657
NotSolved

Ansicht des Beitrags:
Von:
Gast94764
Datum:
22.06.2019 15:31:36
Views:
501
Rating: Antwort:
  Ja
Thema:
Makro zur Zusammenfassung mehrerer Zeilen // Terminserie

Laaaaaaaangsam, jetzt wird es erst richtig was - ;-)

LG

Sub KetteNach()
Dim ShS As Excel.Worksheet                'Quelle
Dim ShT As Excel.Worksheet                'Ziel - Arbeitsblatt
Dim rng, x, z, flag
Dim arr(), ary(), az

Application.ScreenUpdating = False

Set ShS = ThisWorkbook.Sheets("Tabelle1") 'einsetzen wo
Set ShT = ThisWorkbook.Sheets("Tabelle3")


With ShS
   Set rng = .UsedRange.Columns(1).Cells(1)
   Set rng = Range(rng, .Cells(.Rows.Count, rng.Column).End(xlUp).Offset(1)).Resize(, 4)
   arr = rng.Value
End With

   For x = LBound(arr, 1) To UBound(arr, 1) - 1
      
      If flag = False Then z = x
      
      If arr(x, 1) = arr(x + 1, 1) And arr(x, 2) = arr(x + 1, 2) Then
      
         flag = True
      
      Else
         If flag = True Then
            az = az + 1
            ReDim Preserve ary(1 To 4, 1 To az)
            ary(4, az) = arr(x, 3)
            ary(3, az) = arr(z, 3)
            ary(2, az) = arr(x, 2)
            ary(1, az) = arr(x, 1)
            
         Else
            az = az + 1
            ReDim Preserve ary(1 To 4, 1 To az)
            ary(4, az) = arr(x, 3)
            ary(3, az) = arr(x, 3)
            ary(2, az) = arr(x, 2)
            ary(1, az) = arr(x, 1)
         End If
         flag = False
      End If
      
   Next x
   
With ShT
   .Cells.Clear
   .Cells(1).Resize(UBound(ary, 2), UBound(ary, 1)).Value = Application.Transpose(ary)
   If Not IsDate(.Cells(3)) Then .Cells(3) = "Beginn"
   If Not IsDate(.Cells(4)) Then .Cells(4) = "Ende"
   
End With

Application.ScreenUpdating = True

End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
20.06.2019 22:19:29 Elena
NotSolved
20.06.2019 22:31:54 Gast10703
NotSolved
20.06.2019 23:41:30 Mackie
NotSolved
21.06.2019 10:36:02 Elena
NotSolved
21.06.2019 17:56:05 Gast94764
NotSolved
22.06.2019 08:12:09 Elena
NotSolved
Rot Makro zur Zusammenfassung mehrerer Zeilen // Terminserie
22.06.2019 15:31:36 Gast94764
NotSolved
24.06.2019 10:14:39 Elena
NotSolved
24.06.2019 13:15:45 Elena
NotSolved
24.06.2019 13:15:54 Elena
NotSolved
24.06.2019 15:39:11 Gast94764
NotSolved
24.06.2019 23:33:37 Elena
NotSolved
21.06.2019 20:26:54 Gast86657
NotSolved