Neuigkeiten:

Ist euer Problem gelöst, dann bitte den Knopf "Thema gelöst" drücken!

Mobiles Hauptmenü

Suchen über alle Tabellen einer Arbeitsmappe

Begonnen von -Tom-, Februar 03, 2011, 16:10:28

⏪ vorheriges - nächstes ⏩

-Tom-

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-
Computerprobleme??? -> http//www.weber-computerhilfe.de

Fordere keine Anerkennung!
Zeige was und man wird Dich kennen
  •  

-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-

Computerprobleme??? -> http//www.weber-computerhilfe.de

Fordere keine Anerkennung!
Zeige was und man wird Dich kennen
  •