Hallo,
Ich möchte in meiner Arbeitsmappe nach doppelten Zahlen suchen und diese Zahl dann in eine bestimmte Zelle schreiben.
Das ganz soll über alle Tabellen der Arbeitsmappe gehen. Wie kann ich das am besten mit VBA lösen?
-Tom-
Habe nun eine Lösung. Die Lösung für mein Problem sieht so aus:
Public Sub suchen()
Dim bln As Boolean
Dim strSuchbegriff As String
Dim anfang As Integer
Dim ende As Integer
Dim Zelle As Range
Dim inhalt As String
Dim firstAddress
Dim lngZ As Long
Dim anzahl As Integer
Dim ws_Find As Worksheet
Dim CellAddress As String
Dim CellAddressNr As String
Dim firstCellAddress As String
Sheets("DoppelteNrSuchen").Select
Range("D6").Select
anfang = ActiveCell.Value
Range("D7").Select
ende = ActiveCell.Value
zähler = anfang
Rows("10:4615").Select
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
lngZ = 10 'Startzeile für Eintragung in Tabellenblatt DoppelteNrSuchen
Do While anfang < ende
anzahl = 0
strSuchbegriff = anfang
For Each ws_Find In Worksheets
If ws_Find.Name <> "DoppelteNrSuchen" Then
With ws_Find.UsedRange
Set Zelle = .Find(strSuchbegriff, LookIn:=xlValues)
If Not Zelle Is Nothing Then
inhalt = Zelle
firstAddress = Zelle.Address
Do
If Not (firstCellAddress = "") Then
CellAddress = Left(firstCellAddress, 3)
CellAddressNr = Mid(firstCellAddress, 4, 4)
CellAddressNr = CellAddressNr + 1
CellAddress = CellAddress & CellAddressNr
End If
If Not (Zelle.Address = CellAddress) Then
If (NurZahlen = 1) Then
If IsNumeric(inhalt) = True Then
anzahl = anzahl + 1
End If
Else
anzahl = anzahl + 1
End If
If anzahl = 3 Then
Sheets("DoppelteNrSuchen").Select
Range("B" & lngZ).Select
ActiveCell.Value = strSuchbegriff
lngZ = lngZ + 1
ElseIf anzahl = 4 Then
Sheets("DoppelteNrSuchen").Select
Range("B" & lngZ - 1).Select
ActiveCell.Interior.Color = vbRed
ElseIf anzahl > 4 Then
Sheets("DoppelteNrSuchen").Select
Range("B" & lngZ - 1).Select
ActiveCell.Interior.Color = vbGreen
End If
firstCellAddress = Zelle.Address
End If
Set Zelle = .FindNext(Zelle)
Loop While Not Zelle Is Nothing And Zelle.Address <> firstAddress
End If
End With
End If
Next
Set Zelle = Nothing
anfang = anfang + 1
Loop
MsgBox "Fertig!!!"
End Sub
-Tom-