vba-Liste von Daten aus Arbeitsblättern

Hallo Ex(cel)perten,
jede Woche gehe ich Mappen mit mehreren Blättern durch, um gewisse Daten zu sammeln,- vielleicht könnte dieses mit vba verkürzt werden.
Die Mappe hat max. 22 Arbeitsblätter, u.a. mit den Blattnamen 1,2,3 .. bis max. 20
In Arbeitsblatt "Stichworte" steht in "A1" ein Datum.
gesucht wird:
in den Blättern 1 bis max. 20, Spalte "B" nach den Datumswert, die gleich oder höher liegen, als das Datum in Blatt "Stichworte", "A1"
Findet sich das Kriterium, soll aus der gleichen Zeile der Wert in Spalte "AV" und der jeweilige Blattname im Blatt "Stichworte" ab "A2:B2" eingetragen werden. - Weitere "Treffer" darunter.
PS: Ein Blatt kann mehrere "Treffer" haben.
Kann mir bitte jemand bei der Umsetzung helfen.
Mit freundlichen Gruß
Fred Neumann

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub collectData() Dim objWS As Worksheet, rng As Range, lngLast As Long Dim varOut() As Variant, lngI As Long, lngR As Long, lngSheet As Long Dim datSearch As Date datSearch = Sheets("Stichworte").Range("A1") For lngSheet = 1 To 20 If SheetExist(CStr(lngSheet)) Then With Sheets(CStr(lngSheet)) lngLast = Application.Max(1, .Cells(.Rows.Count, 2).End(xlUp).Row) For lngR = 1 To lngLast If IsDate(.Cells(lngR, 2)) Then If .Cells(lngR, 2) >= datSearch Then Redim Preserve varOut(lngI) varOut(lngI) = Array(.Cells(lngR, 48), lngSheet) lngI = lngI + 1 End If End If Next End With End If Next If lngI > 0 Then With Sheets("Stichworte") .Range("A2:B" & .Rows.Count) = "" .Range("A2").Resize(lngI, 2) = Application.Transpose(Application.Transpose(varOut)) End With End If End Sub Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook, Optional ByVal byCodeName As Boolean = False) As Boolean Dim wks As Object On Error GoTo ERRORHANDLER If Wb Is Nothing Then Set Wb = ThisWorkbook For Each wks In Wb.Sheets If byCodeName Then If LCase(wks.CodeName) = LCase(sheetName) Then SheetExist = True: Exit Function Else If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function End If Next ERRORHANDLER: SheetExist = False End Function VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

Hallo Fred,
Modul Modul1

Option Explicit 
 
Sub collectData() 
  Dim objWS As Worksheet, rng As Range, lngLast As Long 
  Dim varOut() As Variant, lngI As Long, lngR As Long, lngSheet As Long 
  Dim datSearch As Date 
 
  datSearch = Sheets("Stichworte").Range("A1") 
 
  For lngSheet = 1 To 20 
    If SheetExist(CStr(lngSheet)) Then 
      With Sheets(CStr(lngSheet)) 
        lngLast = Application.Max(1, .Cells(.Rows.Count, 2).End(xlUp).Row) 
        For lngR = 1 To lngLast 
          If IsDate(.Cells(lngR, 2)) And Not .Rows(lngR).Hidden Then 
            If .Cells(lngR, 2) >= datSearch Then 
              Redim Preserve varOut(lngI) 
              varOut(lngI) = Array(.Cells(lngR, 48).Value, lngSheet) 
              lngI = lngI + 1 
            End If 
          End If 
        Next 
      End With 
    End If 
  Next 
 
  If lngI > 0 Then 
    With Sheets("Stichworte") 
      .Range("A2:B" & .Rows.Count) = "" 
      .Range("A2").Resize(lngI, 2) = Application.Transpose(Application.Transpose(varOut)) 
    End With 
  End If 
 
End Sub 
 
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook, Optional ByVal byCodeName As Boolean = False) As Boolean 
  Dim wks As Object 
  On Error GoTo ERRORHANDLER 
  If Wb Is Nothing Then Set Wb = ThisWorkbook 
  For Each wks In Wb.Sheets 
    If byCodeName Then 
      If LCase(wks.CodeName) = LCase(sheetName) Then SheetExist = True: Exit Function 
    Else 
      If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function 
    End If 
  Next 
ERRORHANDLER: 
  SheetExist = False 
End Function 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

	A	B	C	D	E	F
1	Gruß Sepp
2
3

Option Explicit Sub collectData() Dim objWS As Worksheet, rng As Range, lngLast As Long Dim varOut() As Variant, lngI As Long, lngR As Long, lngSheet As Long Dim datSearch As Date datSearch = Sheets("Stichworte").Range("A1") For lngSheet = 1 To 20 If SheetExist(CStr(lngSheet)) Then With Sheets(CStr(lngSheet)) lngLast = Application.Max(1, .Cells(.Rows.Count, 2).End(xlUp).Row) For lngR = 1 To lngLast If IsDate(.Cells(lngR, 2)) And Not .Rows(lngR).Hidden Then If .Cells(lngR, 2) >= datSearch Then Redim Preserve varOut(lngI) varOut(lngI) = Array(.Cells(lngR, 48).Value, lngSheet) lngI = lngI + 1 End If End If Next End With End If Next With Sheets("Stichworte") .Range("A2:B" & .Rows.Count) = "" If lngI > 0 Then .Range("A2").Resize(lngI, 2) = _ Application.Transpose(Application.Transpose(varOut)) End With End Sub Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook, Optional ByVal byCodeName As Boolean = False) As Boolean Dim wks As Object On Error GoTo ERRORHANDLER If Wb Is Nothing Then Set Wb = ThisWorkbook For Each wks In Wb.Sheets If byCodeName Then If LCase(wks.CodeName) = LCase(sheetName) Then SheetExist = True: Exit Function Else If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function End If Next ERRORHANDLER: SheetExist = False End Function VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

Beliebteste Forumthreads (12 Monate)

vba-Liste von Daten aus Arbeitsblättern

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

268 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

vba-Liste von Daten aus Arbeitsblättern

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

268 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread