Re: Zellen vergleichen und ewtl. ändern.
23.07.2002 20:14:23
MikeS
Hallo Reiner,wenn Deine Tabelle1 so aussieht:
Tabelle: Tabelle1
dann mit ALT+PF11 in die Entwicklungsumgebung wechseln
und links im Verzeichnisbaum "Tabelle2" doppelklicken,
um den nachfolgenden Code einzufügen.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Bereich As Range
Set Bereich = Range("AL:AL") 'alle Einträge in Spalte AL
If Not Intersect(Target, Bereich) Is Nothing Then
Call Zellenvergleich
End If
End Sub
Sub Zellenvergleich()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Zelle As Range
Dim lRow As Long
Dim iCol As Integer
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle2")
Set Zelle = ActiveCell.Offset(-1, 0)
lRow = 2
iCol = 2
Application.ScreenUpdating = False
On Error Resume Next
Do Until lRow > ws1.Cells(65536, 2).End(xlUp).Row
If Zelle = ws1.Cells(lRow, iCol) Or _
Zelle = ws1.Cells(lRow, iCol + 1) Or _
Zelle = ws1.Cells(lRow, iCol + 2) Or _
Zelle = ws1.Cells(lRow, iCol + 3) Or _
Zelle = ws1.Cells(lRow, iCol + 4) Or _
Zelle = ws1.Cells(lRow, iCol + 5) _
Then
Zelle.Offset(0, 1) = ws1.Cells(lRow - 1, iCol)
Exit Sub
Else
lRow = lRow + 3
If lRow > ws1.Cells(65536, 2).End(xlUp).Row Then
Zelle.Offset(0, 1) = Zelle
End If
End If
Loop
Application.ScreenUpdating = True
End Sub
In Tabelle2 wird nach Eingabe in Spalte AL automatisch der
Code gestartet.
Bei mir läuft es perfekt.
Ciao MikeS