VBA - Vereinfachung Doppelter Werte

Hallo zusammen,
Ich versuche mein Problem anhand eines Beispiels zu erklären. Es geht um eine VBA-Lösung.
Beispiel:
Ich habe eine Tabelle1 (siehe Bild unten) mit 3 Geräten, welche über eine Seriennummer eindeutig identifizierbar sind. Diese Geräte wurden von verschiedenen Personen mehrfach installiert und deinstalliert. Diese Installationen und Deinstallationen sind in der Tabelle1 protokolliert:

Nun möchte ich gerne in einem neuen Sheet im gleichen Workbook eine Tabelle2 mit folgenden Eigenschaften anhand Tabelle1 erstellen:
1. Jede Seriennummer ist einmal vertreten.
2. Zudem gilt pro Seriennummer:
- Das Installationsdatum ist das Installationsdatum an dem das Gerät das erste Mal installiert wurde.
- Das Deinstallationsdatum soll das Deinstallationsdatum aus der Zeile mit dem jüngsten Installationsdatum entsprechen (Dies kann entweder ein Datum beinhalten oder leer sein).
- Der Name soll dem Namen aus der Zeile mit dem jüngsten Installationsdatum entsprechen
Hier das Beispiel für Tabelle2:

Anmerkung zu Tabelle1:
Die Einträge sind nicht unbedingt chronologisch nach Installationsdatum sortiert (siehe Gerät mit Seriennr. 3)
Obwohl, das nicht so kompliziert klingt, habe ich keine Lösung erstellen können. Ich hoffe ihr könnt helfen...
Grüße
Sarah

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sarah,
teste mal:

Option Explicit
Private Type DATA
Number As Long
Installation As Date
Deinstallation As Date
Name As String
End Type
Public Sub Extract()
Dim avntValues As Variant, vntItem As Variant
Dim lngCounter As Long, ialngIndex As Long
Dim strFirstAddress As String
Dim udtData() As DATA
Dim objDictionary As Object
Dim objCell As Range
With Tabelle1
avntValues = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value2
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
For Each vntItem In avntValues
If Not IsEmpty(vntItem) Then _
objDictionary.Item(Key:=vntItem) = vbNullString
Next
ReDim udtData(1 To objDictionary.Count)
For Each vntItem In objDictionary.Keys
lngCounter = lngCounter + 1
With udtData(lngCounter)
.Number = vntItem
.Installation = DateSerial(9999, 12, 31)
.Deinstallation = DateSerial(1900, 1, 1)
End With
Set objCell = .Columns(1).Find(What:=vntItem, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole)
strFirstAddress = objCell.Address
Do
With udtData(lngCounter)
.Installation = Application.Min(.Installation, objCell.Offset(0, 1).Value)
If (.Deinstallation  0 Then
.Deinstallation = objCell.Offset(0, 2).Value
.Name = objCell.Offset(0, 3).Value
End If
End With
Set objCell = .Columns(1).FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Next
End With
Set objDictionary = Nothing
Set objCell = Nothing
With Tabelle2
Call .Range(.Cells(2, 1), .Cells(.Rows.Count, 3)).ClearContents
For ialngIndex = 1 To lngCounter
.Cells(ialngIndex + 1, 1).Value = udtData(ialngIndex).Number
.Cells(ialngIndex + 1, 2).Value = udtData(ialngIndex).Installation
If udtData(ialngIndex).Deinstallation > 0 Then _
.Cells(ialngIndex + 1, 3).Value = udtData(ialngIndex).Deinstallation
.Cells(ialngIndex + 1, 4).Value = udtData(ialngIndex).Name
Next
End With
End Sub

Gruß
Nepumuk

Sub umformen() Sheets("Tabelle1").Cells(1, 1).CurrentRegion.Copy With Sheets("Tabelle3") .Cells(1, 1).PasteSpecial xlPasteAll With .Cells(1, 1).CurrentRegion .Sort Header:=xlYes, _ key1:=.Cells(1, 1), order1:=xlAscending, _ key2:=.Cells(1, 2), order2:=xlDescending With .Columns(.Columns.Count + 1) With .Offset(1, 0).Resize(.Rows.Count - 1) .FormulaR1C1 = "=IF(RC1=R[1]C1,R[1]C,RC2)" .Copy .Offset(0, 2 - .Column).PasteSpecial xlPasteValues .ClearContents End With End With .RemoveDuplicates 1, xlYes End With End With End Sub

Dim arrQuelle, arrErg Dim dic Dim arrDatensatz Dim z As Long, sp As Long Dim ID Set dic = CreateObject("scripting.dictionary") arrQuelle = Sheets("Tabelle1").Cells(1, 1).CurrentRegion '--- Daten erstellen For z = 2 To UBound(arrQuelle, 1) ID = arrQuelle(z, 1) If dic.exists(ID) Then arrDatensatz = dic(ID) If arrDatensatz(2) > arrQuelle(z, 2) Then arrDatensatz(2) = arrQuelle(z, 2) If arrDatensatz(5)

Beliebteste Forumthreads (12 Monate)

VBA - Vereinfachung Doppelter Werte

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA - Vereinfachung Doppelter Werte

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread