Übersicht füllen

Hallo zusammen,
mittels eines Makros hier aus dem Forum kopiere ich die Tabellen aus mehreren Dateien in eine Datei. Das klappt auch bestens.
Jetzt soll ich in dem Reiter ÜBersicht dieser Masterdatei Felder aus den ausgelesen Tabellen bestücken oder einlesen. Hier stehen mir Mangels Wissen und Können tausend Hürden im Weg.
- alle Tabellen (ab der 2) müssen mittels einer Schleife ausgelesen werden
- hierzu muss für jedes Tabellenblatt der Schutz aufgehoben werden ("Claudia")
- dann müssen in die Spalten D bis O im Reiter "Übersicht" die Werte aus den anderen Tabellen (die Zellangaben aus den Tabellen habe ich in Zeile 1 geschrieben. Sie sind für alle Tabellen identisch)eingetragen werden
Ich habe mal das erste Blatt als DAtei eingefügt:
https://www.herber.de/bbs/user/65987.xls
Wer kann mir bei dieser kniffligen Aufgabe helfen?
Ich sage schon einmal danke im Voraus!
Liebe Grüße
Claudia

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Claudia,
probie mal.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub datenSammeln()
  Dim objSh As Worksheet, objShUe As Worksheet
  Dim lngLast As Long, lngRow As Long, lngCol As Long, lngLastCol As Long

  Set objShUe = Sheets("Übersicht")

  With objShUe
    lngLast = Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row)
    lngLastCol = Application.Max(4, .Cells(1, .Columns.Count).End(xlToLeft).Column)

    For lngRow = 2 To lngLast
      If SheetExist(.Cells(lngRow, 2).Text) Then
        Set objSh = Sheets(.Cells(lngRow, 2).Text)
        For lngCol = 4 To lngLastCol
          If isRange(.Cells(1, lngCol).Text) Then .Cells(lngRow, lngCol) = objSh.Range(.Cells(1, lngCol).Text)
        Next
      End If
    Next

  End With


  Set objShUe = Nothing
  Set objSh = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Private Function isRange(ByVal Text As String) As Boolean
  Dim rng As Range
  On Error Resume Next
  Set rng = Range(Text)
  On Error GoTo 0
  isRange = Not rng Is Nothing
  Set rng = Nothing
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread