Aufgelistete Blätter durchsuchen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Aufgelistete Blätter durchsuchen von: Eleni
Geschrieben am: 07.02.2005 13:26:30

Hi Forum,

Habe in einer Mappe mehrere Tabellen und ein Blatt mit einer Auflistung von bestimmten (nicht allen) Tabellenblättern dieser Mappe. Ein Makro soll nun eine Übersicht mit bestimmten Daten erstellen. Allerdings soll es nur in den Tabellenblättern nach Daten suchen, die in der Liste auch aufgeführt sind. Für die Übersichtserstellung habe ich einen Makro-Code, aber wie kann ich dem Makro sagen, dass es nur die aufgelisteten Tabellenblätter durchsuchen soll?


Ciao, Eleni

Bild


Betrifft: AW: Aufgelistete Blätter durchsuchen von: Josef Ehrensberger
Geschrieben am: 07.02.2005 13:46:25

Hallo Eleni!

Das könnte man so lösen!


      
Sub suche()
Dim rng As Range

For Each rng In Range("deinBereich")   'Bereich mit den Tabellennamen!
   If SheetExist(Trim(rng.text)) Then
   
   
'dein Suchcode
   
   
End If
Next
End Sub


Private Function SheetExist(ByVal sheetName As StringOptional WbName As StringAs Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = 
False
End Function 


     Code eingefügt mit Syntaxhighlighter 3.0



Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: Aufgelistete Blätter durchsuchen von: Eleni
Geschrieben am: 07.02.2005 14:08:07

Hi Sepp,

Danke, erstmal für den Code. Jetzt kriege ich aber 'ne Fehlemeldung mit meinem Suchcode, 'ne Idee? Mit einer "for each ws in this workbook" - Schleife funktionierte er noch. Hier dein Code mit meinem Suchmakro:

Sub suche()
    ThisWorkbook.Sheets("Übersicht_1").Activate
    Dim rng As Range
    For Each rng In Range("A3", Cells(Rows.Count, 1).End(xlUp))
        If SheetExist(Trim(rng.Text)) Then
            ThisWorkbook.Sheets("Übersicht").Activate
            Dim myWs As Worksheet, ws As Worksheet
            Dim lng As Long, zei As Long
            Dim n
            Set ws = Worksheets("Übersicht")
            With ws
            zei = 3
                
                    If myWs.Name <> ws.Name And myWs.Name <> "Abkürzungsverzeichnis" And myWs.Name <> "Vorlage" Then
                        lng = myWs.[c65536].End(xlUp).Row
                            For n = 3 To lng Step 10
                                myWs.Range("A3").Copy
                                ws.Range("A" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("B3").Copy
                                ws.Range("B" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("S" & n & ":S" & n).Copy
                                ws.Range("D" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("C" & n & ":C" & n).Copy
                                ws.Range("E" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("J" & n & ":J" & n).Copy
                                ws.Range("F" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("T" & n & ":T" & n).Copy
                                ws.Range("G" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("U" & n & ":U" & n).Copy
                                ws.Range("H" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("V" & n & ":V" & n).Copy
                                ws.Range("I" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("W" & n & ":W" & n).Copy
                                ws.Range("J" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("X" & n & ":X" & n).Copy
                                ws.Range("K" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                                myWs.Range("Y" & n & ":Y" & n).Copy
                                ws.Range("L" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            zei = zei + 1
                            Next n
                    End If
            
            End With
            ThisWorkbook.Sheets("Übersicht").Columns("A:F").EntireColumn.AutoFit
            ThisWorkbook.Sheets("Übersicht").Columns("K:L").EntireColumn.AutoFit
            ThisWorkbook.Sheets("Übersicht").Protect Password:="zeit"
        End If
    Next
End Sub



Ciao, Eleni


Bild


Betrifft: AW: Aufgelistete Blätter durchsuchen von: Josef Ehrensberger
Geschrieben am: 07.02.2005 17:19:17

Hallo Eleni!

Ungetestet!


      
Option Explicit

Sub suche()
Dim myWs As Worksheet, ws As Worksheet
Dim lng As Long, zei As Long, lastRow As Long, n As Long
Dim rng As Range


Set ws = Worksheets("Übersicht")

lastRow = ws.Range(
"A65536").End(xlUp).Row

zei = 3

ws.Unprotect Password:=
"zeit"

   
For Each rng In ws.Range("A3:A" & lastRow)
   
      
If SheetExist(Trim(rng.Text)) Then
      
      
Set myWs = Sheets(Trim(rng.Text))
      
         
If myWs.Name <> ws.Name And myWs.Name <> "Abkürzungsverzeichnis" And _
                           myWs.Name <> 
"Vorlage" Then
                           
         lng = myWs.[c65536].End(xlUp).Row
         
            
For n = 3 To lng Step 10
            
               myWs.Range(
"A3").Copy
               ws.Range(
"A" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"B3").Copy
               ws.Range(
"B" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"S" & n & ":S" & n).Copy
               ws.Range(
"D" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"C" & n & ":C" & n).Copy
               ws.Range(
"E" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"J" & n & ":J" & n).Copy
               ws.Range(
"F" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"T" & n & ":T" & n).Copy
               ws.Range(
"G" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"U" & n & ":U" & n).Copy
               ws.Range(
"H" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"V" & n & ":V" & n).Copy
               ws.Range(
"I" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"W" & n & ":W" & n).Copy
               ws.Range(
"J" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"X" & n & ":X" & n).Copy
               ws.Range(
"K" & zei).PasteSpecial Paste:=xlValues
               myWs.Range(
"Y" & n & ":Y" & n).Copy
               ws.Range(
"L" & zei).PasteSpecial Paste:=xlValues
               
               zei = zei + 1
               
            
Next
            
         
End If
         
      
End If
      
   
Next

Application.CutCopyMode = 
False

ws.Columns(
"A:F").EntireColumn.AutoFit
ws.Columns(
"K:L").EntireColumn.AutoFit
ws.Protect Password:=
"zeit"

End Sub

Private Function SheetExist(ByVal sheetName As StringOptional WbName As StringAs Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = 
False
End Function 


     Code eingefügt mit Syntaxhighlighter 3.0




Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: Wow, klappte auf Anhieb. DANKE - Geschlossen, o.T. von: Eleni
Geschrieben am: 07.02.2005 17:29:41

o. T.


Bild


Betrifft: AW: Aufgelistete Blätter durchsuchen von: UweD
Geschrieben am: 07.02.2005 13:52:42

Hallo


so ginge es.


Sub listen()
    Dim SP%, LR%, i%, TB
    SP = 1 ' Werte stehen in Spalte A
    LR = ActiveSheet.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
    For i = 1 To LR
        TB = ActiveSheet.Cells(i, SP).Value ' TabellenName Lesen
        If TB <> "" Then
            On Error GoTo Fehler
            ' hier kann dein Makro einsetzten
            'Beispiel
            MsgBox "Ich bearbeite gerade Tabelle '" & TB & "'" & Chr(13) _
                & " Wert aus  A1 ist: " & Sheets(TB).[A1].Value
            '
        End If
    Next
Exit Sub
Fehler:
    If Err.Number = 9 Then
        MsgBox "Tabelle '" & TB & "' nicht vorhanden"
        Err.Clear
    End If
    Resume Next
End Sub



Bild


Betrifft: AW: Aufgelistete Blätter durchsuchen von: Eleni
Geschrieben am: 07.02.2005 14:16:19

Hi UweD,

Danke fürs Makro, aber es macht irgendwie nix. Hier dein Code mit meinem Suchmakro:

Sub listen()
    Dim SP%, LR%, i%, TB
    SP = 1 ' Werte stehen in Spalte A
    LR = Sheets("Übersicht_1").Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
    For i = 1 To LR
        TB = Sheets("Übersicht_1").Cells(i, SP).Value ' TabellenName Lesen
        If TB <> "" Then
            On Error GoTo Fehler
        ThisWorkbook.Sheets("Übersicht").Activate
        Dim myWs As Worksheet, ws As Worksheet
        Dim lng As Long, zei As Long
        Dim n
        Set ws = Worksheets("Übersicht")
        With ws
        zei = 3
                If myWs.Name <> ws.Name And myWs.Name <> "Abkürzungsverzeichnis" And myWs.Name <> "Vorlage" Then
                    lng = myWs.[c65536].End(xlUp).Row
                        For n = 3 To lng Step 10
                            myWs.Range("A3").Copy
                            ws.Range("A" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("B3").Copy
                            ws.Range("B" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("S" & n & ":S" & n).Copy
                            ws.Range("D" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("C" & n & ":C" & n).Copy
                            ws.Range("E" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("J" & n & ":J" & n).Copy
                            ws.Range("F" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("T" & n & ":T" & n).Copy
                            ws.Range("G" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("U" & n & ":U" & n).Copy
                            ws.Range("H" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("V" & n & ":V" & n).Copy
                            ws.Range("I" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("W" & n & ":W" & n).Copy
                            ws.Range("J" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("X" & n & ":X" & n).Copy
                            ws.Range("K" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                            myWs.Range("Y" & n & ":Y" & n).Copy
                            ws.Range("L" & zei).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        zei = zei + 1
                        Next n
                End If
            
        End With
    ThisWorkbook.Sheets("Übersicht").Columns("A:F").EntireColumn.AutoFit
    ThisWorkbook.Sheets("Übersicht").Columns("K:L").EntireColumn.AutoFit
        End If
    Next
Exit Sub
Fehler:
    If Err.Number = 9 Then
        MsgBox "Tabelle '" & TB & "' nicht vorhanden"
        Err.Clear
    End If
    Resume Next
End Sub



Ciao, Eleni


Bild


Betrifft: Geschlossen, o. T. von: Eleni
Geschrieben am: 08.02.2005 14:18:41

o. T.


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Aufgelistete Blätter durchsuchen"