Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 12:09:19
Unique (Application.WorksheetFunction.Unique)
19.04.2024 11:51:37
Nächsten identischen Treffer suchen
19.04.2024 11:45:34
Feld im SAP auslesen
19.04.2024 10:59:29
Datei Auswählen und öffnen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
560to564
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
560to564
560to564
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Aufgelistete Blätter durchsuchen

Aufgelistete Blätter durchsuchen
07.02.2005 13:26:30
Eleni
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

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Aufgelistete Blätter durchsuchen
07.02.2005 13:46:25
Josef
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 String, Optional WbName As String) As 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 


Gruß Sepp
P.S.: Rückmeldung nicht vergessen!
Anzeige
AW: Aufgelistete Blätter durchsuchen
07.02.2005 14:08:07
Eleni
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
Anzeige
AW: Aufgelistete Blätter durchsuchen
07.02.2005 17:19:17
Josef
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 String, Optional WbName As String) As 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 


Gruß Sepp
P.S.: Rückmeldung nicht vergessen!
Anzeige
Wow, klappte auf Anhieb. DANKE - Geschlossen, o.T.
07.02.2005 17:29:41
Eleni
o. T.
AW: Aufgelistete Blätter durchsuchen
UweD
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

Anzeige
AW: Aufgelistete Blätter durchsuchen
07.02.2005 14:16:19
Eleni
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
Anzeige
Geschlossen, o. T.
08.02.2005 14:18:41
Eleni
o. T.

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige