Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1396to1400
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
Inhaltsverzeichnis

Tabellenblätter finden und auslesen

Tabellenblätter finden und auslesen
06.12.2014 23:45:20
Ralph
Hallo Excelfreunde,
ich habe ein Tabellenblatt "Main" mit verschiedenen Zahlen in Spalte A (ca. 5000). Zusätzlich habe ich 3 Tabellenblätter (XX123, XX391, XX109), in denen auch verschiedene Zahlen in Spalte A stehen.
Ich brauche nun einen Code der mir im Tabellenblatt "Main" in Spalte B-D angibt, ob sich diese Zahl in den Tabellenblättern XX123, XX391 und XX109 wiederfindet. Die Anzahl der Tabellenblätter XX... muss variabel sein, es sind zwischen 2 bis max. 15. Der Code muss also alle Tabellenblätter finden, die "XX" im Namen beinhalten. Der Name des Tabellenblatts soll in Zeile A der entsprechenden Zeile geschrieben werden.
Um mein Anliegen etwas verdeutlichen zu können, habe ich mal eine Beispielmappe gebaut. Ob sich die Werte in den jeweiligen Tabellenblättern befinden würde ich mit Formlen lösen können, aber das Auslesen wieviele Tabellenblätter "XX" im Namen beinhalten und die Schleife zum Auslesen und Anlegen der Spalten in "Main" macht mir Kopfzerbrechen...
Danke für Eure Hilfe! Gruss Ralph

https://www.herber.de/bbs/user/94252.xls

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenblätter finden und auslesen
07.12.2014 00:40:48
Mullit
Hallo,
könntest Du z.B. so machen:
Option Explicit

Public Sub test()
  Dim wksSheet As Worksheet
  Dim avntArray As Variant
  Dim astrOutput() As String
  Dim vntElem As Variant
  Dim ialngRow As Long, ialngColumn As Long
  With Worksheets("Main")
      .Cells(2, 2).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
      ialngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      avntArray = .Cells(2, 1).Resize(ialngRow, 1)
      For Each wksSheet In Worksheets
         With wksSheet
             If Left$(String:=.Name, Length:=2) = "XX" Then
               ialngColumn = ialngColumn + 1
               Redim Preserve astrOutput(ialngRow - 1, ialngColumn - 1) As String
               ialngRow = 0
               For Each vntElem In avntArray
                  ialngRow = ialngRow + 1
                  If Not IsError(Application.Match(vntElem, .Cells(1, 1).Resize(ialngRow, 1), 0)) Then
                    astrOutput(ialngRow - 1, ialngColumn - 1) = .Name
                  Else
                    astrOutput(ialngRow - 1, ialngColumn - 1) = vbNullString
                  End If
               Next
             End If
         End With
      Next
      .Cells(2, 2).Resize(ialngRow, ialngColumn) = astrOutput
  End With
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Gruß,

Anzeige
AW: Tabellenblätter finden und auslesen
07.12.2014 00:56:00
Ralph
Hallo "Mullit",
vielen Dank für Deinen Vorschlag - das sieht schonmal super aus!
Beim Testen haben sich noch 2-3 Fragen/Wünsche ergeben:
1. Ich möchte die Auflistung evtl nicht in Spalte B beginnen sondern später. Wo ist die erste Spalte definiert?
2. Liesse sich der jeweilige Tabellenname noch als Überschrift in Zeile 1 schreiben?
3. Wenn keine Tabellenblätter mit "XX" vorhanden sind gibts einen Fehler. Liesse sich das noch abfangen? Sorry, hatte mich falsch ausgedrückt.
Nochmals vielen vielen Dank! Gruss Ralph

AW: Tabellenblätter finden und auslesen
07.12.2014 01:42:12
Mullit
Hallo Ralph,
prima; null Problemo, sollte so gehen; werden keine Blätter mit XX gefunden, bleiben die alten Daten in Main noch erhalten, sonst müsste man die ClearContents-Anweisung wieder an den Kopf der Prozedur setzen:
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long
    
Public Sub test()
  Const START_COLUMN As Long = 2
  Const SEARCH_STRING As String = "XX"
  Dim wksSheet As Worksheet
  Dim avntArray As Variant
  Dim astrOutput() As String
  Dim vntElem As Variant
  Dim ialngRow As Long, ialngColumn As Long
  With Worksheets("Main")
      ialngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      avntArray = .Cells(2, 1).Resize(ialngRow, 1)
      For Each wksSheet In Worksheets
         With wksSheet
             If Left$(String:=.Name, Length:=2) = SEARCH_STRING Then
               ialngColumn = ialngColumn + 1
               Redim Preserve astrOutput(ialngRow, ialngColumn - 1) As String
               ialngRow = 0
               astrOutput(ialngRow, ialngColumn - 1) = .Name
               For Each vntElem In avntArray
                  ialngRow = ialngRow + 1
                  If Not IsError(Application.Match(vntElem, .Cells(1, 1).Resize(ialngRow, 1), 0)) Then
                    astrOutput(ialngRow, ialngColumn - 1) = .Name
                  Else
                    astrOutput(ialngRow, ialngColumn - 1) = vbNullString
                  End If
               Next
             End If
         End With
      Next
      If CBool(SafeArrayGetDim(astrOutput)) Then
        .Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count - 1).ClearContents
        .Cells(1, START_COLUMN).Resize(ialngRow + 1, ialngColumn) = astrOutput
        .Cells(1, START_COLUMN).Resize(1, .UsedRange.Columns.Count - 1).Font.Bold = True
      Else
        MsgBox "Keine TabBlätter mit " & "'" & SEARCH_STRING & _
           "'" & " im Namen vorhanden!", vbExclamation
      End If
  End With
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Gruß, Mullit

Anzeige
AW: Tabellenblätter finden und auslesen
07.12.2014 01:57:47
Ralph
Hallo "Mullit",
danke für Deine Arbeit! Jetzt bekomme ich n Laufzeitfehler wenn mind. 1 Blatt mit XX vorhanden ist:

.Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count - 1). _
ClearContents

Wäre super wenn Du da nochmal schauen würdest. Danke!!

AW: Tabellenblätter finden und auslesen
07.12.2014 02:14:36
Mullit
Hallo Ralph,
hmmm, ich erhalte keinen Fehler, aber es könnte an der Usedrange-Eigenschaft liegen, hat dann nichts mit den Tabblättern zu tun, ersetz mal diesen Teil:
'...
If CBool(SafeArrayGetDim(astrOutput)) Then
.Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
.Cells(1, START_COLUMN).Resize(ialngRow + 1, ialngColumn) = astrOutput
.Cells(1, START_COLUMN).Resize(1, .UsedRange.Columns.Count).Font.Bold = True
Else
MsgBox "Keine TabBlätter mit " & "'" & SEARCH_STRING & _
"'" & " im Namen vorhanden!", vbExclamation
End If
'...

Sollte der Fehler weiter bestehen lad' nochmal 'ne Testdatei hoch...
Gruß, Mullit

Anzeige
AW: Tabellenblätter finden und auslesen (ERL)
07.12.2014 02:30:25
Ralph
Hallo Mullit,
nun funktioniert es fehlerfrei.
Ich weiss nicht was ich sagen soll... GENIAL! Danke vielmals!!!
Wünsche Dir noch einen schönen Morgen & evtl. bis ein anderes Mal ;o)
Ralph

AW: Tabellenblätter finden und auslesen (ERL)
07.12.2014 13:18:43
Ralph
Hallo Mullit,
ich habe Deinen Code soweit in die endgültige Version eingebaut. Dabei haben sich nun doch noch 2 weitere Wünsche ergeben, ich wäre Dir sehr dankbar wenn Du diese noch mit einbauen würdest.
1. Den Suchbegriff "XX" möchte ich ersetzen durch "XX_". Leider funktioniert das mit dem Sonderzeichen nicht da die Mappe nicht gefunden wird.
2. Wäre es noch möglich dass in Zeile A nicht der komplette Tabellenname steht sondern nur der Name ohne "XX_"? (Bsp.: Tabelle heisst "XX_A123", in Zeile A soll als Überschrift "A123" stehen.
Besten Dank nochmals und Gruss, Ralph

Anzeige
AW: Tabellenblätter finden und auslesen (ERL)
07.12.2014 19:39:47
Mullit
Hallo Ralph,
prima; null Problemo, ersteres kannst Du einfach in der SEARCH_STRING-Konstante ändern:
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long
    
Public Sub test()
  Const START_COLUMN As Long = 2
  Const SEARCH_STRING As String = "XX_"
  Dim wksSheet As Worksheet
  Dim avntArray As Variant
  Dim avntOutput() As Variant
  Dim vntElem As Variant
  Dim ialngRow As Long, ialngColumn As Long
  With Worksheets("Main")
      ialngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      avntArray = .Cells(2, 1).Resize(ialngRow, 1)
      For Each wksSheet In Worksheets
         With wksSheet
             If Left$(String:=.Name, Length:=Len(SEARCH_STRING)) = SEARCH_STRING Then
               ialngColumn = ialngColumn + 1
               Redim Preserve avntOutput(ialngRow, ialngColumn - 1) As Variant
               ialngRow = 0
               avntOutput(ialngRow, ialngColumn - 1) = Mid$(String:=.Name, Start:=Len(SEARCH_STRING) + 1)
               For Each vntElem In avntArray
                  ialngRow = ialngRow + 1
                  If Not IsError(Application.Match(vntElem, .Cells(1, 1).Resize(ialngRow, 1), 0)) Then
                    avntOutput(ialngRow, ialngColumn - 1) = .Name
                  Else
                    avntOutput(ialngRow, ialngColumn - 1) = vbNullString
                  End If
               Next
             End If
         End With
      Next
      If CBool(SafeArrayGetDim(avntOutput)) Then
        .Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
        .Cells(1, START_COLUMN).Resize(ialngRow + 1, ialngColumn) = avntOutput
        .Cells(1, START_COLUMN).Resize(1, .UsedRange.Columns.Count).Font.Bold = True
      Else
        MsgBox "Keine TabBlätter mit " & "'" & SEARCH_STRING & _
           "'" & " im Namen vorhanden!", vbExclamation
      End If
  End With
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Gruß, Mullit

Anzeige
AW: Tabellenblätter finden und auslesen (ERL)
07.12.2014 21:24:36
Ralph
Nabend Mullit,
super dass Du Dich meiner nochmal annimmst. Ich weiss, so langsam wirds peinlich..
Aber wäre es noch möglich, dass in die Zellen auch (wie in der Überschrift) die gekürzte Version ohne "XX_" eingetragen wird?
Vielen vielen Dank, Ralph

AW: Tabellenblätter finden und auslesen (ERL)
07.12.2014 22:00:46
Mullit
Hallo Ralph,
naaa, ich weiß schon, ist nicht immer leicht abzuschätzen, was man eigentlich haben will, sollte so gehen:
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long
    
Public Sub test()
  Const START_COLUMN As Long = 2
  Const SEARCH_STRING As String = "XX_"
  Dim wksSheet As Worksheet
  Dim avntArray As Variant
  Dim avntOutput() As Variant
  Dim vntElem As Variant
  Dim strName As String
  Dim ialngRow As Long, ialngColumn As Long
  Application.ScreenUpdating = False
  With Worksheets("Main")
      ialngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      avntArray = .Cells(2, 1).Resize(ialngRow, 1)
      For Each wksSheet In Worksheets
         With wksSheet
             If Left$(String:=.Name, Length:=Len(SEARCH_STRING)) = SEARCH_STRING Then
               ialngColumn = ialngColumn + 1
               Redim Preserve avntOutput(ialngRow, ialngColumn - 1) As Variant
               ialngRow = 0
               strName = Mid$(String:=.Name, Start:=Len(SEARCH_STRING) + 1)
               avntOutput(ialngRow, ialngColumn - 1) = strName
               For Each vntElem In avntArray
                  ialngRow = ialngRow + 1
                  If Not IsError(Application.Match(vntElem, .Cells(1, 1).Resize(ialngRow, 1), 0)) Then
                    avntOutput(ialngRow, ialngColumn - 1) = strName
                  Else
                    avntOutput(ialngRow, ialngColumn - 1) = vbNullString
                  End If
               Next
             End If
         End With
      Next
      If CBool(SafeArrayGetDim(avntOutput)) Then
        .Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
        .Cells(1, START_COLUMN).Resize(ialngRow + 1, ialngColumn) = avntOutput
        .Cells(1, START_COLUMN).Resize(1, .UsedRange.Columns.Count).Font.Bold = True
      Else
        MsgBox "Keine TabBlätter mit " & "'" & SEARCH_STRING & _
           "'" & " im Namen vorhanden!", vbExclamation
      End If
  End With
  Application.ScreenUpdating = True
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Gruß, Mullit

Anzeige
AW: Tabellenblätter finden und auslesen (ERL)
07.12.2014 22:16:34
Ralph
Hallo Mullit,
super ich danke Dir sehr!! Funktioniert einwandfrei :-)
Ich hoffe ich muss jetzt nichts mehr anpassen (lassen).
Once again: DANKE!
Gruss Ralph

Top:: owT
07.12.2014 22:24:51
Mullit

AW: Top:: owT
08.12.2014 22:47:21
Ralph
Hallo Mullit,
ich konnte Deinen Code heute mit echten Daten testen. Dabei hat sich herausgestellt, dass nicht alle Zeilen entsprechend markiert wurden. 1264 Zeilen hätten markiert werden müssen, 370 davon wurden vergessen. Ich habe eine Testmappe gebaut um mein Problem genau darstellen zu können.
https://www.herber.de/bbs/user/94290.xlsm
Es wäre (mal wieder) super wenn Du Dir das nochmal ansehen würdest.
Danke & viele Grüsse, Ralph.

Anzeige
AW: Top:: owT
09.12.2014 00:24:57
Mullit
Hallo Ralph,
uuuh böse Falle, da müssen noch zwei Variablen her:
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long
    
Public Sub test()
  Const START_COLUMN As Long = 2
  Const SEARCH_STRING As String = "XX_"
  Dim wksSheet As Worksheet
  Dim objRange As Range
  Dim avntArray As Variant
  Dim avntOutput() As Variant
  Dim vntElem As Variant
  Dim strName As String
  Dim ialngRow As Long, ialngColumn As Long
  Dim lngRow As Long
  Application.ScreenUpdating = False
  With Worksheets("Main")
      lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      avntArray = .Cells(2, 1).Resize(lngRow, 1)
      For Each wksSheet In Worksheets
         With wksSheet
             If Left$(String:=.Name, Length:=Len(SEARCH_STRING)) = SEARCH_STRING Then
               ialngColumn = ialngColumn + 1
               Redim Preserve avntOutput(lngRow, ialngColumn - 1) As Variant
               strName = Mid$(String:=.Name, Start:=Len(SEARCH_STRING) + 1)
               avntOutput(lngRow, ialngColumn - 1) = strName
               Set objRange = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)
               For Each vntElem In avntArray
                  ialngRow = ialngRow + 1
                  If Not IsError(Application.Match(vntElem, objRange, 0)) Then
                    avntOutput(ialngRow, ialngColumn - 1) = strName
                  Else
                    avntOutput(ialngRow, ialngColumn - 1) = vbNullString
                  End If
               Next
             End If
         End With
      Next
      If CBool(SafeArrayGetDim(avntOutput)) Then
        .Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
        .Cells(1, START_COLUMN).Resize(1, ialngColumn).Font.Bold = True
        .Cells(1, START_COLUMN).Resize(ialngRow + 1, ialngColumn) = avntOutput
        Set objRange = Nothing
      Else
        MsgBox "Keine TabBlätter mit " & "'" & SEARCH_STRING & _
           "'" & " im Namen vorhanden!", vbExclamation
      End If
  End With
  Application.ScreenUpdating = True
End Sub

Public Sub ctrltest()
With Worksheets("Main")
    MsgBox WorksheetFunction.CountIf(.Cells(1, 2).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1), "T123") _
      & vbCr & vbCr & "Hopefully 1264...;-)"
End With
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

ScreenUpdating ruhig drin lassen, dann läuft's 'ruckelfrei', hoffentlich kommen wir jetzt der Sache näher...
Gruß, Mullit

Anzeige
AW: Top:: owT
09.12.2014 15:50:03
Ralph
Hallo Mullit,
jetzt schreibt er leider die Überschrift nicht mehr in die 1. Zeile.. ;-)
Danke für Deine Rückmeldung! Gruss Ralph

AW: Top:: owT
09.12.2014 15:59:55
Mullit
Hallo Ralph,
eine Long-Variable hat sich noch versteckt.....
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long
    
Public Sub test()
  Const START_COLUMN As Long = 2
  Const SEARCH_STRING As String = "XX_"
  Dim wksSheet As Worksheet
  Dim objRange As Range
  Dim avntArray As Variant
  Dim avntOutput() As Variant
  Dim vntElem As Variant
  Dim strName As String
  Dim ialngRow As Long, ialngColumn As Long
  Dim lngRow As Long
  Application.ScreenUpdating = False
  With Worksheets("Main")
      lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      avntArray = .Cells(2, 1).Resize(lngRow, 1)
      For Each wksSheet In Worksheets
         With wksSheet
             If Left$(String:=.Name, Length:=Len(SEARCH_STRING)) = SEARCH_STRING Then
               ialngColumn = ialngColumn + 1
               Redim Preserve avntOutput(lngRow, ialngColumn - 1) As Variant
               strName = Mid$(String:=.Name, Start:=Len(SEARCH_STRING) + 1)
               avntOutput(0, ialngColumn - 1) = strName
               Set objRange = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)
               For Each vntElem In avntArray
                  ialngRow = ialngRow + 1
                  If Not IsError(Application.Match(vntElem, objRange, 0)) Then
                    avntOutput(ialngRow, ialngColumn - 1) = strName
                  Else
                    avntOutput(ialngRow, ialngColumn - 1) = vbNullString
                  End If
               Next
             End If
         End With
      Next
      If CBool(SafeArrayGetDim(avntOutput)) Then
        .Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
        .Cells(1, START_COLUMN).Resize(1, ialngColumn).Font.Bold = True
        .Cells(1, START_COLUMN).Resize(ialngRow + 1, ialngColumn) = avntOutput
        Set objRange = Nothing
      Else
        MsgBox "Keine TabBlätter mit " & "'" & SEARCH_STRING & _
           "'" & " im Namen vorhanden!", vbExclamation
      End If
  End With
  Application.ScreenUpdating = True
End Sub

Public Sub ctrltest()
With Worksheets("Main")
    MsgBox WorksheetFunction.CountIf(.Cells(1, 2).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1), "T123") _
      & vbCr & vbCr & "Hopefully 1264...;-)"
End With
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Und nu...? Stimmen die Werte...?
Gruß, Mullit

Anzeige
AW: Top:: owT
09.12.2014 16:38:03
Ralph
Moin Mullit,
ich bleibe optimistisch ;-)
Jetzt läuft er leider auf Fehler bei mehr als einer Mappe mit "XX_":

avntOutput(ialngRow, ialngColumn - 1) = vbNullString

Bis später ;-) DANKE, Ralph

AW: Top:: owT
10.12.2014 01:22:40
Mullit
Hallo Ralph,
das reicht leider von erschreckend schwach bis absolut tödlicher Fehler; die Long-Vars sind Killer...
ich bleibe optimistisch ;-)

Aber das ehrt Dich: es fehlte die Initialisierung von ialngRow = 0:
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long
    
Public Sub test()
  Const START_COLUMN As Long = 2
  Const SEARCH_STRING As String = "XX_"
  Dim wksSheet As Worksheet
  Dim objRange As Range
  Dim avntArray As Variant
  Dim avntOutput() As Variant
  Dim vntElem As Variant
  Dim strName As String
  Dim ialngRow As Long, ialngColumn As Long
  Dim lngRow As Long
  Application.ScreenUpdating = False
  With Worksheets("Main")
      lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
      avntArray = .Cells(2, 1).Resize(lngRow, 1)
      For Each wksSheet In Worksheets
         With wksSheet
             If Left$(String:=.Name, Length:=Len(SEARCH_STRING)) = SEARCH_STRING Then
               ialngColumn = ialngColumn + 1
               Redim Preserve avntOutput(lngRow, ialngColumn - 1) As Variant
               strName = Mid$(String:=.Name, Start:=Len(SEARCH_STRING) + 1)
               avntOutput(0, ialngColumn - 1) = strName
               Set objRange = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)
               ialngRow = 0
               For Each vntElem In avntArray
                  ialngRow = ialngRow + 1
                  If Not IsError(Application.Match(vntElem, objRange, 0)) Then
                    avntOutput(ialngRow, ialngColumn - 1) = strName
                  Else
                    avntOutput(ialngRow, ialngColumn - 1) = vbNullString
                  End If
               Next
             End If
         End With
      Next
      If CBool(SafeArrayGetDim(avntOutput)) Then
        .Cells(1, START_COLUMN).Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count).ClearContents
        .Cells(1, START_COLUMN).Resize(1, ialngColumn).Font.Bold = True
        .Cells(1, START_COLUMN).Resize(ialngRow + 1, ialngColumn) = avntOutput
        Set objRange = Nothing
      Else
        MsgBox "Keine TabBlätter mit " & "'" & SEARCH_STRING & _
           "'" & " im Namen vorhanden!", vbExclamation
      End If
  End With
  Application.ScreenUpdating = True
End Sub

Public Sub ctrltest()
With Worksheets("Main")
    MsgBox WorksheetFunction.CountIf(.Cells(2, 2).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1), "T123") _
      & vbCr & vbCr & "Hopefully 1264...;-)"
End With
End Sub


VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel



Code erstellt und getestet in Office 12

Versuchen wir beide optimistisch zu bleiben und schmeiß bei der Gelegenheit die Test-Sub ctrltest an, ob jedesmal die Werte stimmen...
Gruß, Mullit

AW: Top:: owT
11.12.2014 20:38:57
Ralph
Hallo Mullit,
ich konnte den Code bisher noch nicht ausgiebig testen. Die ersten Versuche mit verschiedener Anzahl Mappen liefen aber alle problemlos. Sollte wieder was auftauchen werde ich mich melden.
DANKE!! Gruss Ralph

AW: Top:: owT
12.12.2014 01:09:32
Mullit
Hallo Ralph,
freut mich zu hören, gut durchgehalten...top::
Gruß, Mullit

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige