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:
634
Rating: Antwort:
  Ja
Thema:
Makro zur Zusammenfassung mehrerer Zeilen // Terminserie

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

LG

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
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