AW: Eine bestimmte Zahl ersetzen
11.09.2015 20:20:53
JoWE
und nochmal:
Option Explicit
'Aufgabe: Doppler in Zeilen ersetzen durch Ersetzwerte aus Zeile 1
'in den Zeilen sollen im Ergebnis keine Doppler stehen bleiben
Sub start()
Dim wb As Workbook
Dim sh As Worksheet
Set wb = ThisWorkbook
Set sh = wb.Sheets("Tabelle1") 'Anpassen
Dim dlZe As Long 'Laufariable geht alle Zeile durch
Dim dlSp As Long 'Laufvaribale geht jede Splate jeder Zeile durch
Dim pruefer As Long 'wenn pruefer >1 ist ist der Wert in der Zeile doppelt
Dim n As Long 'wenn n = 2 wird der gefundene Doppler ersetzt
Dim ersetzSp As Long 'Variable für die Spalte die den Ersetzwert aus Zeile 1 liefert
Dim ber As String 'der Bereich für die Dopplersuch wird in jede Zeile neu gesetzt
'um ein wenig Schreibarbeit zu sparen
With sh
'los geht es in Zeile 4
For dlZe = 4 To 123 'alle Zeilen werden "abgegrast"
ersetzSp = 3: n = 0 'Startwert bestimmter Variablen für Durchlauf setzen
'jetzt den Bereich für die gerade aktuelle Zeile setzen
ber = .Range(.Cells(dlZe, 2), .Cells(dlZe, 9)).Address
'jetzt wird die Zeile horizontal durchsucht
For dlSp = 2 To 9
sh.Cells(dlZe, dlSp).Select
'Inhalt der Zelle prüfen
pruefer = Application.WorksheetFunction.CountIf(.Range(ber), .Cells(dlZe, dlSp))
'gibt es den Wert in der Zeile mehrfach wird zunächst der Zähler n um den Wert 1 erhöht
If pruefer > 1 Then n = n + 1
'wenn n > 1 ist wird der 2. Doppler ersetzt
If n > 1 Then
'die Splate die den Ersetzwert aus Zeile 1 liefert auf den Startwert 4 setzen
ersetzSp = ersetzSp + 1
'jetzt wird der Doppler ersetzt
.Cells(dlZe, dlSp).Value = .Cells(1, ersetzSp).Value
'der Ersetwert kann in der Zeile ja auch schon vorhanden sein
'daher erneut aif Doppler prüfen
If Application.WorksheetFunction.CountIf(.Range(ber), .Cells(dlZe, dlSp)) > 1 Then
'ein erneuter Doppler wird durch einen anderen Ersetzwert ersetzt
ersetzSp = ersetzSp + 1
.Cells(dlZe, dlSp).Value = .Cells(1, ersetzSp).Value
If Application.WorksheetFunction.CountIf(.Range(ber), .Cells(dlZe, dlSp)) > 1 Then
'ein erneuter Doppler wird durch einen anderen Ersetzwert ersetzt
ersetzSp = ersetzSp + 1
.Cells(dlZe, dlSp).Value = .Cells(1, ersetzSp).Value
If Application.WorksheetFunction.CountIf(.Range(ber), .Cells(dlZe, dlSp)) > 1 _
Then
'ein erneuter Doppler wird durch einen anderen Ersetzwert ersetzt
ersetzSp = ersetzSp + 1
.Cells(dlZe, dlSp).Value = .Cells(1, ersetzSp).Value
End If
End If
End If
End If
Next
Next
End With
End Sub
mit immer mehr Wiederholung wird's irgendwann.
Das Problem sind die Ersetzwerte, die ja auch alle immer mal in der Tabelle enthalten sind und jeweils neue Doppler bilden.
Gruß
Jochen
