Mehrfach vergleichen
21.03.2005 09:42:55
ah
habe ein kleines Problemchen,
habe ein MAkro, welches mir zwei TAbellen vergleicht, jedoch vergleicht es nur einmal und dann nicht mehr, wenns die gleiche Tabelle ist.
Es soll aber immer wieder vergleichen und immer wieder es hin schreiben.
D.h. das Makro vergleicht.Ich lasse es nochmal laufen und es vergleicht nochmal und uberschreibt die Werte nicht, sondern schreibt mir die nächsten werte in die nächste freie Zeile.
Uch hoffe, dass das einigermaßen verständlich war.
Hier der Code
Sub Vergleichen()
Dim LoI As Long
Dim LoLetzte1 As Long
Dim Loletzte3 As Long
Dim c As Object
Dim z%
With Worksheets("sheet1")
LoLetzte1 = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536)
End With
For LoI = 1 To LoLetzte1 'Sheet1 wird durchlaufen und mit Verweis verglichen!!!
' Leerzellen nicht kennzeichnen
Set c = Worksheets("Übersicht").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Worksheets("sheet1").Cells(LoI, 2).Value <> "" And c Is Nothing Then
Set c = Worksheets("Verweis").Columns(1).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Not c Is Nothing Then
startzeile = LoI
summe = Worksheets("sheet1").Cells(LoI, 3).Value
z = 1
zeile = LoI
Do
Set c = Worksheets("sheet1").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2), after:=Worksheets("sheet1").Cells(zeile, 2), lookat:=xlWhole)
If c.Row <> startzeile Then
summe = summe + Worksheets("sheet1").Cells(c.Row, 3).Value
z = z + 1
zeile = c.Row
End If
Loop Until c.Row = startzeile
Worksheets("sheet1").Rows(LoI).Copy
With Worksheets("Übersicht")
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If Loletzte3 > 65536 Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
Application.CutCopyMode = False
Exit Sub
End If
.Rows(Loletzte3).PasteSpecial Paste:=xlValues ' Werte
.Rows(Loletzte3).PasteSpecial Paste:=xlFormats ' Formate
.Cells(Loletzte3, 3).Value = summe
.Cells(Loletzte3, 4).Value = z
End With
End If
End If
Next LoI
Application.CutCopyMode = False
End Sub
Vielen DAnk
ah