AW: erweiterte Spalten vergleichen!
15.10.2005 16:09:01
gordon
Hi Guido,
Lösung in folgender Datei.
https://www.herber.de/bbs/user/27532.xls
Code:
Option Explicit
Sub RapidTableReporter()
' _R_apid_T_able_R_eporter ( RTL ) ;-)
' Vergleich der jeweils ersten Spalte zweier Worksheets auf Doubletten
Dim rDienst1 As Range, _
rDienst2 As Range, _
wsD2 As Worksheet, _
wsMit As Worksheet, _
wsNichtMit As Worksheet, _
c As Range, _
cFound As Range, _
rlc As Range, _
iRowCountMit As Long, _
iRowCountNichtMit As Long
Set wsMit = Worksheets("mitgemacht")
Set wsNichtMit = Worksheets("nicht mitgemacht")
With Worksheets("Dienst1")
Set rlc = .Range("A65536")
If rlc.Value = 0 Then Set rlc = .Range("A65536").End(xlUp)
Set rDienst1 = .Range(.Cells(2, 1), .Cells(rlc.Row, 1))
End With
Set wsD2 = Worksheets("Dienst2")
With wsD2
Set rlc = .Range("A65536")
If rlc.Value = 0 Then Set rlc = .Range("A65536").End(xlUp)
Set rDienst2 = .Range(.Cells(2, 1), .Cells(rlc.Row, 1))
End With
iRowCountMit = 3
iRowCountNichtMit = 3
For Each c In rDienst1
Set cFound = rDienst2.Find(c.Value)
If cFound Is Nothing Then
'nicht mitgemacht
c.EntireRow.Copy (wsNichtMit.Cells(iRowCountNichtMit, 1))
iRowCountNichtMit = iRowCountNichtMit + 1
Else
' mitgemacht
c.EntireRow.Copy (wsMit.Cells(iRowCountMit, 1))
With wsD2
.Range(cFound.Offset(0, 1), .Cells(cFound.Row, 6)).Copy (wsMit.Cells(iRowCountMit, 7))
End With
iRowCountMit = iRowCountMit + 1
End If
Next ' c in rDienst1
Set wsNichtMit = Nothing
Set wsMit = Nothing
End Sub
Feedback wäre schön
Gruß
gordon