Beispiel: Tabellenvergleich und Übernahme der Dopp

Sub Vergleich() Dim wks As Worksheet Dim iRow As Integer, iAct As Integer, iRowC As Integer Dim iRowT As Integer, iCol As Integer, iColC As Integer Dim bln As Boolean Set wks = ActiveSheet iRowC = WorksheetFunction.CountA(Columns(1)) iColC = WorksheetFunction.CountA(Rows(1)) iRow = 1 Worksheets.Add after:=Worksheets(Worksheets.Count) For iRow = 1 To iRowC For iAct = 1 To iRowC If iRow iAct Then bln = False iCol = 3 If wks.Cells(iRow, iCol).Value wks.Cells(iAct, iCol).Value Then bln = True End If If bln = False Then iRowT = iRowT + 1 Range(Cells(iRowT, 1), Cells(iRowT, iRowC)).Value = _ wks.Range(wks.Cells(iRow, 1), wks.Cells(iRow, iRowC)).Value End If End If Next iAct Next iRow Columns.AutoFit End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Stefan,
ich habe Zeit gehabt, also habe den Code einbischen veraendert. Probiere es bitte aus und sag Bescheid.
Gruss dan, cz.
Option Explicit


Public Sub Vergleich()
Dim wks As Worksheet
Dim iRow As Integer, iAct As Integer, rowsCount As Integer
Dim iRowT As Integer, iCol As Integer, columnsCount As Integer
Dim valuesEqual As Boolean
Dim copiedRows() As Long
Set wks = ActiveSheet
rowsCount = Range("A65536").End(xlUp).Row ' WorksheetFunction.CountA(Columns(1))
columnsCount = Range("IV1").End(xlToLeft).Column ' WorksheetFunction.CountA(Rows(1))
iRow = 1
iCol = 3
ReDim copiedRows(0)
Worksheets.Add after:=Worksheets(Worksheets.Count)
For iRow = 1 To rowsCount
If (CellValueOK(wks.Cells(iRow, iCol))) Then
For iAct = 1 To rowsCount
If iRow  iAct And CellValueOK(wks.Cells(iAct, iCol)) Then
valuesEqual = False
If wks.Cells(iRow, iCol).Value = wks.Cells(iAct, iCol).Value Then
valuesEqual = True
End If
' nur dann kopieren wenn:
' - die Werte gleich sind
' - die Zeile hat man noch nicht kopiert
If valuesEqual And NotCopied(copiedRows, iRow) Then
iRowT = iRowT + 1
Range(Cells(iRowT, 1), Cells(iRowT, columnsCount)).Value = _
wks.Range(wks.Cells(iRow, 1), wks.Cells(iRow, columnsCount)).Value
ReDim Preserve copiedRows(UBound(copiedRows) + 1)
copiedRows(UBound(copiedRows)) = iRow
End If
End If
Next iAct
End If
Next iRow
Columns.AutoFit
End Sub

' ist iRow schon kopiert?


Private Function NotCopied(ByRef copiedRows As Variant, ByVal iRow As Long) As Boolean
Dim i As Long
Dim copied As Boolean
copied = False
For i = LBound(copiedRows) To UBound(copiedRows)
If (copiedRows(i) = iRow) Then
copied = True
Exit For
End If
Next i
NotCopied = Not copied
End Function

' check if die Zelle nicht leer ist, nicht mit error, nicht empty ...


Private Function CellValueOK(ByRef Cell As Range) As Boolean
Dim cellValue As Variant
cellValue = Cell.Value
CellValueOK = True
If (VBA.IsError(cellValue)) Then
CellValueOK = False
ElseIf (VBA.IsEmpty(cellValue)) Then
CellValueOK = False
ElseIf (cellValue = "") Then
CellValueOK = False
End If
End Function

Beliebteste Forumthreads (12 Monate)

Beispiel: Tabellenvergleich und Übernahme der Dopp

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread