For-Next-Auswahl für A bis Z

Servus alle Aktiven,
ich habe ein Archiv von A bis Z (entspricht 26 Tabellen-Blätter)
die ich nach einem Text-String (z.B. : "duk*"), des Spalten-Bereichs "A:B"
automatisch durch suchen möchte und alles was "duk" entspricht oder enthält,
soll zeilenweise ("An:Gn") nacheinander ausgegeben werden.
1. Mein eigentliches Problem ist folgendes :
wie spreche ich auf einfache Weise in einer Schleife alle Tabellen-Blätter
von A bis Z an ?
Eine aufwändige Möglichkeit währe diese (nur auszugsweise) :
Sub Suchen_In()
Dim Zähler As Integer
Dim Alph As String
Alph(1)="A"
Alph(2)="B"
Alph(3)="C"
...
Alph(26)="Z"
For Zähler= 1 To 26
... Alph(Zähler) ...
Next Zähler
...
Was leider nicht funktioniert ist
Alph= "A" To "Z"
...
Next Alph
(habe ich schon ausprobiert)
Wer weiss eine einfache und kompakte Lösung ?
2. Such- und Archivierungs-Routinen für oben benannte Anwendung,
in einer einfachen und kompakten Form.
Mein Programm-Code ist viel zu aufwändig, kompliziert
und viel zu langsam in der Ausführung.
Vielen Dank im Voraus.
Michael

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Suchen() 'For-Next-Schleife für A bis Z der Blätter "A" bis "Z" Dim Blatt As Worksheet Dim AlphaString As String For Each Blatt In ActiveWorkbook.Worksheets Select Case Blatt.Name Case "A" To "Z" AlphaString = ActiveSheet.Cells(1, 2).Value MsgBox ("Anzeige der Variablen Blatt in der Schleife" _ & (Chr(10)) & (Chr(10)) & AlphaString) End Select Next Blatt End Sub

Hallo Michael, ich hatte einbischen Zeit gehabt, also habe ich versucht Deine Aufgabe zu loesen. Hier das Ergebniss. Ob es kompakt und schnell genug ist, musst Du entscheiden :-). Am Anfang des Codes sind die Konstanten, die Du aendern kannst. Also z.B. SUCHEN_DEFAULT muss nicht "duk" sein, aber z.B. "Duck" :-), usw. Hoffentlich wird der Code funzen! Falls nicht, oder falls Du Fragen haben solltest, schreib mir an DDMAIL@seznam.cz (ab Dienstag sollte ich wieder in der Arbeit sitsen :-)). Gruss kdosi, CZ
======================================================================================´

Option Explicit
Private Const SPALTEN_BEREICH As String = "A:B"
Private Const SUCHEN_DEFAULT As String = "duk"
Private Const KOPIEREN_BEREICH_VON As String = "A"
Private Const KOPIEREN_BEREICH_BIS As String = "G" ' (z.B. "An:Gn")
Private Const ERBEBNISS_TABELLE_NAME As String = "Ergebniss"
Public Sub Main()
    Dim wshTabelle As Worksheet
    Dim wshErgaebnis As Worksheet
    Dim vntTabellen As Variant
    Dim vntWasSuchen As Variant
    Dim rngBereichGefunden As Range



    If (Not Application.ActiveWorkbook Is Nothing) Then

        Set vntTabellen = Application.ActiveWorkbook.Worksheets

        ' falls Sheet ERBAEBNIS_TABELLE_NAME schon existiert, loeschen
        On Error Resume Next

        Dim vntTemp As Variant
        Set vntTemp = Nothing
        Set vntTemp = vntTabellen(ERBEBNISS_TABELLE_NAME)

        If (Not vntTemp Is Nothing) Then
            Application.DisplayAlerts = False
            vntTabellen(ERBEBNISS_TABELLE_NAME).Delete
            Application.DisplayAlerts = True
        End If

        ' Sheet ERBAEBNIS_TABELLE_NAME zugeben
        On Error GoTo Err_In_SubMain

        ' Function Add([Before], [After], [Count], [Type]) As Object
        Set wshErgaebnis = vntTabellen.Add(vntTabellen(1), , 1, xlWorksheet)
        wshErgaebnis.Name = ERBEBNISS_TABELLE_NAME
    Else
        End
    End If

    ' der User kann andere Suchkette eingeben
    vntWasSuchen = Application.InputBox("Geben Sie die Kette, die gesucht werden soll.", _
                                        "Suchen", SUCHEN_DEFAULT)

    ' User hat auf Storno geklickt
    If (vntWasSuchen = False) Then End

    ' wir gehen die Tabellen durch und suchen die Kette in vntWasSuchen
    For Each wshTabelle In vntTabellen

        If (wshTabelle.Name <> ERBEBNISS_TABELLE_NAME) Then
            Set rngBereichGefunden = Suchen(VBA.CStr(vntWasSuchen), _
                                            wshTabelle.Range(SPALTEN_BEREICH), _
                                            KOPIEREN_BEREICH_VON, _
                                            KOPIEREN_BEREICH_BIS)

            ' wenn die gesuchte Kette existierte, rngBereichGefunden kopieren in die Tabelle ERBAEBNIS_TABELLE_NAME
            If (Not rngBereichGefunden Is Nothing) Then

                ' Test machen, ob schon Daten im Sheet sind, oder nicht
                If (wshErgaebnis.Range("a1").CurrentRegion.Address(False, False) = "A1") Then
                    rngBereichGefunden.Copy wshErgaebnis.Range("a1")
                Else
                    rngBereichGefunden.Copy wshErgaebnis.Range("a" & VBA.CStr(Rows.Count)).End(xlUp).Offset(1, 0)
                End If

            End If

        End If

    Next wshTabelle

    Exit Sub

Err_In_SubMain:

    Call VBA.MsgBox("Laufzeitsfehler Nummer " & Err.Number, vbCritical, "Fehler")
    End
End Sub
Private Function Suchen(ByVal i_strGesuchteKette As String, _
                        ByVal i_rngBereich As Range, _
                        ByVal i_strKopierenBereichVon As String, _
                        ByVal i_strKopierenBereichBis As String) As Range

    Set Suchen = Nothing

    Dim rngZelle As Range
    Dim rngBereichUsed As Range

    ' wir werden suchen nur in dem Teil des Bereiches, wo Werte sind, damit es nicht so lange dauert
    Set rngBereichUsed = Application.Intersect(i_rngBereich, i_rngBereich.Parent.UsedRange)

    If (Not rngBereichUsed Is Nothing) Then

        For Each rngZelle In rngBereichUsed.Cells
            If (VBA.InStr(1, VBA.CStr(rngZelle.Value), i_strGesuchteKette) > 0) Then
                If (Not Suchen Is Nothing) Then
                    Set Suchen = Application.Union(Suchen, _
                                 i_rngBereich.Parent.Range(i_strKopierenBereichVon & VBA.CStr(rngZelle.Row) & ":" & _
                                 i_strKopierenBereichBis & VBA.CStr(rngZelle.Row)))
                Else
                    Set Suchen = i_rngBereich.Parent.Range(i_strKopierenBereichVon & VBA.CStr(rngZelle.Row) & ":" & _
                                 i_strKopierenBereichBis & VBA.CStr(rngZelle.Row))
                End If
            End If
        Next rngZelle

    End If

End Function

Sub BlaetterDurchsuchen() Dim i As Integer, j As Byte, rng As Range, str As String, str2 As String str = "*duk*" For j = 1 To 26 For i = 1 To Sheets.Count If Sheets(i).Name = Chr(64 + j) Then For Each rng In Sheets(i).Range("A1:B" & Sheets(i).Range("B65536").End(xlUp).Row) If rng Like str Then str2 = str2 & vbLf & Sheets(i).Name & " " & _ rng.Address(RowAbsolute:=False, columnAbsolute:=False) End If Next End If Next Next MsgBox "Der Begriff " & str & " ist an" & vbLf & _ "folgenden Stellen enthalten:" & vbLf & vbLf & "Blatt" & " " & "Zelle" & vbLf & str2 End Sub

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

For-Next-Auswahl für A bis Z

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread