VBA Schleifen zur Identifizierung von Vertragslaufzeiten pro Seriennummer

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Dominik,
ich habe es nochmal umgebaut. Jetzt musst du nur noch die zwei Konstanten START_YEAR und END_YEAR anpassen, den Rest macht das Programm von selbst.

Option Explicit

Private Const START_YEAR As Long = 2012
Private Const END_YEAR As Long = 2022

Private Type DATA
    Number As Long
    Years(START_YEAR To END_YEAR) As Variant
End Type

Public Sub Auswertung()
    Dim audtData() As DATA
    Dim avntValues As Variant
    Dim ialngIndex As Long, ialngCount As Long, ialngYear As Long
    Dim objDictionary As Object
    With Worksheets("Tabelle1")
        avntValues = .Range(.Cells(2, 2), .Cells(Rows.Count, 4).End(xlUp)).Value
    End With
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    With objDictionary
        For ialngIndex = LBound(avntValues) To UBound(avntValues)
            If Not .Exists(Key:=avntValues(ialngIndex, 1)) Then
                Redim Preserve audtData(ialngCount)
                With audtData(ialngCount)
                    .Number = avntValues(ialngIndex, 1)
                    For ialngYear = START_YEAR To END_YEAR
                        .Years(ialngYear) = 0
                    Next
                End With
                Call .Add(Key:=avntValues(ialngIndex, 1), Item:=ialngCount)
                ialngCount = ialngCount + 1
            End If
            With audtData(.Item(Key:=avntValues(ialngIndex, 1)))
                For ialngYear = Year(avntValues(ialngIndex, 2)) To Year(avntValues(ialngIndex, 3))
                    .Years(ialngYear) = "x"
                Next
            End With
        Next
    End With
    Set objDictionary = Nothing
    Redim avntValues(LBound(audtData) To UBound(audtData), START_YEAR To END_YEAR + 1)
    For ialngIndex = LBound(audtData) To UBound(audtData)
        With audtData(ialngIndex)
            avntValues(ialngIndex, START_YEAR) = .Number
            For ialngYear = START_YEAR To END_YEAR
                avntValues(ialngIndex, ialngYear + 1) = .Years(ialngYear)
            Next
        End With
    Next
    Application.ScreenUpdating = False
    With Worksheets("Tabelle1")
        .Range(.Cells(2, 6), .Cells(.Rows.Count, END_YEAR - START_YEAR + 7)).ClearContents
        .Range(.Cells(2, 6), .Cells(UBound(avntValues, 1) + 2, END_YEAR - START_YEAR + 7)).Value = avntValues
    End With
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk

Hallo Dominik,
genügt das? Für weitere Erklärungen bitte nachfragen.

Option Explicit

Private Const START_YEAR As Long = 2012
Private Const END_YEAR As Long = 2022

'benutzerdefinierten Datentyp deklarieren
Private Type DATA
    Number As Long
    Years(START_YEAR To END_YEAR) As Variant
End Type

Public Sub Auswertung()
    'leeres Array des benutzerdefinierten Datentyps deklarieren
    Dim audtData() As DATA
    Dim avntValues As Variant
    Dim ialngIndex As Long, ialngCount As Long, ialngYear As Long
    Dim objDictionary As Object
    With Worksheets("Tabelle1")
        'Daten der Spalte B-D ab Zeile 2 bis zur letzten benutzten Zeile einlesen
        avntValues = .Range(.Cells(2, 2), .Cells(Rows.Count, 4).End(xlUp)).Value
    End With
    'Dictionary-Objekt erzeugen (ist ein Array mit eindeutigen Schlüssel und Wert)
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    'Verweis auf das Dictionary-Objekt öffnen
    With objDictionary
        'Schleife über die Werte von spalte B-D
        For ialngIndex = LBound(avntValues) To UBound(avntValues)
            'Wenn der Schlüssel noch nicht existiert
            If Not .Exists(Key:=avntValues(ialngIndex, 1)) Then
                'Array des benutzerdefinierten Datentyps erweitern
                Redim Preserve audtData(ialngCount)
                'Verweis auf diesen Arrayeintrag öffnen
                With audtData(ialngCount)
                    'Equipment-Nummer speichern
                    .Number = avntValues(ialngIndex, 1)
                    'Schleife über die Jahre
                    For ialngYear = START_YEAR To END_YEAR
                        'eine 0 in jedes Jahr schreiben
                        .Years(ialngYear) = 0
                    Next
                End With
                'Schlüssel und Zähler im Dictionary speichern
                Call .Add(Key:=avntValues(ialngIndex, 1), Item:=ialngCount)
                'Zähler hochsetzen
                ialngCount = ialngCount + 1
            End If
            'Verweis auf den Arrayeintrag mit dem endsprechenden Schlüssel öffnen
            With audtData(.Item(Key:=avntValues(ialngIndex, 1)))
                'Schleife über die Jahre aus Spalte C und D
                For ialngYear = Year(avntValues(ialngIndex, 2)) To Year(avntValues(ialngIndex, 3))
                    'im entsprechenden Jahr ein x eintragen
                    .Years(ialngYear) = "x"
                Next
            End With
        Next
    End With
    'Objekt zurücksetzen
    Set objDictionary = Nothing
    'Ausgabearray für jeden Eintrag im benutzerdefinierten Array in Zeilen
    'und für jedes Jahr + 1 für die Equipment-Nummer in Spalten anlegen
    Redim avntValues(LBound(audtData) To UBound(audtData), START_YEAR To END_YEAR + 1)
    'Schleife ber das benutzerdefinierten Array
    For ialngIndex = LBound(audtData) To UBound(audtData)
        With audtData(ialngIndex)
            'Equipment-Nummer in das Ausgabearray schreiben
            avntValues(ialngIndex, START_YEAR) = .Number
            'Schleife über die Jahre
            For ialngYear = START_YEAR To END_YEAR
                'Eintrag 0 oder x in das Ausgabearray schreiben
                avntValues(ialngIndex, ialngYear + 1) = .Years(ialngYear)
            Next
        End With
    Next
    'Bildschirmaktualisierung ausschalten
    Application.ScreenUpdating = False
    With Worksheets("Tabelle1")
        'Ausgabebereich löschen
        .Range(.Cells(2, 6), .Cells(.Rows.Count, END_YEAR - START_YEAR + 7)).ClearContents
        'Ausgabearray ausgeben
        .Range(.Cells(2, 6), .Cells(UBound(avntValues, 1) + 2, END_YEAR - START_YEAR + 7)).Value = avntValues
    End With
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

VBA Schleifen zur Identifizierung von Vertragslaufzeiten pro Seriennummer

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Schleifen zur Identifizierung von Vertragslaufzeiten pro Seriennummer

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread