AW: Tabellenblätter erstellen mit Makro danach einlese
27.01.2012 15:55:32
Dirk
Hallo Thomas
Hier der Code mit Färbung der bereits verteilten emailadd
hab auch noch einen Fehler behoben (add ohne umlaute hat er doppelt koppiert)
Einfach den kompletten code austauschen.
solle dir eine andere Farbe leiber sein kannst du einfach kurz ein Makro aufzeichnen und eine Zelle Färben.
aus diesem Code nimmst du dann die zeile .ThemeColor ="Feldfarbe als code " und tauschst diese in den Code hier aus
Viel Spaß damit
Dirk
Sub t1()
Dim v, n, fz, su As Variant
Dim l, i, dg, u1, u2, u3 As Integer
Dim en As Boolean
With ActiveSheet.Range("a2:AB2000")
Set az = .Find(what:="*", after:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlPrevious)
End With
l = az.Row
Set n = ActiveSheet.Range("b2", Range("b2").End(xlDown))
For dg = 1 To l - 1
u1 = 0
u2 = 0
u3 = 0
For i = 1 To 2
If i = 1 Then
su = "*" & n(dg) & "*"
ElseIf i = 2 Then
On Error Resume Next
su = n(dg)
u1 = InStrRev(su, "ü")
u2 = InStrRev(su, "ö")
u3 = InStrRev(su, "ä")
If u1 = 0 And u2 = 0 And u3 = 0 Then
MsgBox (su)
GoTo dgweiter
Else
su = Replace(su, "ü", "ue")
su = Replace(su, "ö", "oe")
su = Replace(su, "ä", "ae")
su = "*" & su & "*"
End If
End If
With ActiveSheet.Range("c2:c" & l)
Set fz = .Find(what:=su, after:=.Range("A1"), LookIn:=xlValues, _
lookat:=xlWhole, searchdirection:=xlNext)
If fz Is Nothing Then
GoTo ni
End If
erstadd = fz.Address
Do
With Range("c" & fz.Row).Interior
.ThemeColor = xlThemeColorAccent6
End With
Range("d" & dg + 1).Select
efc
ActiveCell = fz
Set fz = .FindNext(fz)
Loop While Not fz Is Nothing And fz.Address erstadd
End With
ni:
Next i
dgweiter:
Next dg
End Sub
Private Sub efc()
Do While ActiveCell ""
ActiveCell.Offset(0, 1).Range("A1").Select
Loop
End Sub