@Sepp u.a. VBA-Könner - Makro anpassen!
15.12.2004 20:04:45
Fritz
vor einigen Tagen wurde mir hier der nachfolgende Code entwickelt, mit dem ich aus einer Tabelle Datensätze in diverse Tabellen einfüge. Wenn ich nun in der Quelltabelle "Daten2" Änderungen vornehme und das Makro laufen lasse, werden bereits vorher bestehende Datensätze erneut in die Zieltabelle eingefügt, d.h. in den Zieltabellen stehen in solchen Fällen die Datensätze mehrfach.
Könnte man das Makro so ändern, dass es - im relevanten Bereich der Zieltabellen - bestehende Daten vorher löscht, so dass eine "echte" Aktualisierung in den Zieltabellen stattfindet.
Ich hoffe wieder einmal auf eure Unterstützung und bedanke mich bereits jetzt für jede Form von Hilfe.
Gruß
Fritz
Hier der Code:
Sub Test()
Dim rng As Range
Dim wks As Worksheet
Dim lastRow As Long
Dim lRow As Long
Dim arr1() As Variant
Dim arr2() As Variant
Dim x As Long, n As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
Set wks = Sheets("Daten2")
lastRow = wks.Range("I65536").End(xlUp).Row
For Each rng In wks.Range("I2:I" & lastRow)
With Sheets(rng.Text)
ReDim Preserve arr1(n)
arr1(n) = rng.Text
n = n + 1
lRow = .Cells(65536, 1).End(xlUp).Row + 1
If lRow < 5 Then lRow = 5
.Cells(lRow, 3) = wks.Cells(rng.Row, 10)
.Cells(lRow, 2) = wks.Cells(rng.Row, 7)
.Cells(lRow, 1) = wks.Cells(rng.Row, 6)
End With
Next
QuickSort arr1
For n = 0 To UBound(arr1)
If arr1(n) <> arr1(n + 1) Then
ReDim Preserve arr2(x)
arr2(x) = arr1(n)
x = x + 1
End If
Next
For n = 0 To UBound(arr2)
With Sheets(arr2(n))
.Range("A5:C65536").Sort Key1:=.Range("B5"), Order1:=xlAscending, Key2:=.Range("C5") _
, Order2:=xlAscending, Key3:=.Range("A5"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1) < T1)
P1 = P1 + 1
Loop
Do While (data(P2) > T1)
P2 = P2 - 1
Loop
If P1 <= P2 Then
T2 = data(P1)
data(P1) = data(P2)
data(P2) = T2
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG
End Sub