Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
136to140
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
136to140
136to140
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zellen vergleichen und ewtl. ändern.

Zellen vergleichen und ewtl. ändern.
23.07.2002 11:14:57
Reiner
Hallo,

habe folgendes Problem. Ich Habe eine Tabelle mit 2 Hauptkommissionen.
Jede der 2 Hauptkommissionen erhält in der nächsten Zeile, 5 Unterkommissionen.(zb.B1 H-Kom und B2:G2 Unterkom, analog dessen für die 2 H-Kom. B4 und B5:G5 )
Nun möchte ich in einer zweiten Tabelle eine Zelle untersuchen, ob eine der Unterkommissionen enthalten ist. Wenn Ja dann soll in einer Nachbarzelle die Hauptkommission erscheinen, ansonsten soll der Wert in einer Nachbarzelle enthalten bleiben.

Ich bin für jede Lösung dankbar.

Gruß
Reiner



4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Zellen vergleichen und ewtl. ändern.
23.07.2002 13:02:15
MikeS
Hi Reiner,

versuch mal das:

Tabelle: Tabelle1

Tabelle: Tabelle2

Den Code in ein Modul:

Option Explicit

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
lRow = 2
iCol = 2
Application.ScreenUpdating = False

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).Value = ws1.Cells(lRow - 1, iCol).Value
Exit Sub
Else
lRow = lRow + 3
End If
Loop

Application.ScreenUpdating = True
End Sub

Den Code starten, nachdem die aktive Zelle in Tabelle2
selektiert wurde.

Klappt`s so???

Ciao MikeS

Anzeige
Re: Zellen vergleichen und ewtl. ändern.
23.07.2002 14:24:57
Reiner
Hallo Mike,

vielen Dank für deinen Beitrag.
Da ich kein VBA Profi bin habe ich etwas Schwierigkeiten mit deinem Code. Was muß ich ändern, das er mir nicht vorkommende Unterkommissionen so übernimmt wie sie in der Zelle stehen.
Und muß ich das Makro für jede Zelle neu aufrufen.
Meie Zielzellen stehen in AL und AM.

Gruß
Reiner

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

Anzeige
Re: Zellen vergleichen und ewtl. ändern.
24.07.2002 07:14:13
Reiner
Hallo Mike,
Vielen Dank für deine mühe, läuft wunderbar.

Gruß
Reiner

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige