VBA - Daten aus mehreren in ein Tabellenblatt

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

Betrifft: VBA - Daten aus mehreren in ein Tabellenblatt
von: Josef
Geschrieben am: 03.12.2015 15:17:38

Hallo zusammen,
ich habe eine relativ harte Nuss, bei der ich nicht weiterkomme und hoffe auf eure Hilfe.
Hier ein grobes Beispiel, welches darstellen soll, was ich habe und wohin ich möchte:
https://www.herber.de/bbs/user/101988.xlsm
Ich hoffe das Beispiel und meine Ausführungen sind verständlich.
Ausgangslage: ich habe eine Excel-Mappe mit vielen Tabellenblättern, aufgebaut wie Tabelle1 und Tabelle2 in meiner Beispieldatei. Jedes Tabellenblatt behandelt eine Ktr-Nummer (Spalte A). Spalte B und D enthalten die Kto-Nummer und dessen Bezeichnung. In Spalte W wird die RST-ID gebildet. Spalte C und H sind ausgegraut, da sie für das Makro nicht relevant sind.
Ich möchte nun ein Makro haben, welches zunächst nach dem Monat fragt, der behandelt werden soll und dann Zeile für Zeile folgendes überprüft:

  • RST-ID (wenn vorhanden) enthält kein „x“

  • Betrag des Monats (Spalte I bis T, je nachdem welcher Monat) ist nicht 0

  • Wenn beides true ergibt, sollen die Informationen dieser Zeile und der passende Betrag in ein neues Sammel-Tabellenblatt kopiert werden, welches erstellt wird. Der Name des neuen Tabellenblatts soll aus dem Wort „RST“ und dem eingegeben Monat inkl. Jahr bestehen (im Beispiel also „03,15“).
    Das Makro soll so alle Zeilen in allen Tabellenblättern durchlaufen und die passenden Informationen in ein Sammel-Tabellenblatt schreiben. Jedes Tabellenblatt hat dabei einen beschriebenen Bereich von ca. 130 Zeilen.
    Wie gesagt, ich hoffe es ist einigermaßen verständlich.
    Ich habe schonmal mit der Abfrage angefangen, kam aber nicht weiter. Hier was ich bisher habe:
    Sub RST()
    Const X As String = "x"
    Dim Zelle As Range
    Dim Monat As Long
        
    Monat = Application.InputBox("Bitte Leistungsmonat eingeben.")
        
        
    For Each Zelle In ActiveSheet.Range("W4:W4")
    If InStr(Zelle.Value, X) = 0 And Zelle.Offset(0, Monat - 15).Value <> 0 Then
    Debug.Print Zelle.Offset(0, Monat - 15).Address
    'Zu Testzwecken debug.print
    End If
    Next Zelle
    End Sub

    Ich bin für alle Vorschläge offen.
    LG
    Jupp

    Bild

    Betrifft: AW: VBA - Daten aus mehreren in ein Tabellenblatt
    von: Sepp
    Geschrieben am: 03.12.2015 17:26:55
    Hallo Jupp,
    probier mal.

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

    Option Explicit

    Sub RST()
    Dim objWS As Worksheet, objWSNew As Worksheet
    Dim rng As Range
    Dim varMonth As Variant, varCol As Variant
    Dim varOut() As Variant, varTemp(8) As Variant
    Dim lngI As Long, lngN As Long
    Dim strName As String
    Dim CalculationMode As Long

    On Error GoTo ErrorHandler

    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      CalculationMode = .Calculation
      .Calculation = xlManual
      .DisplayAlerts = False
    End With

    varMonth = Application.InputBox("Bitte geben sie den Leistungsmonat an!", "Leistungsmonat", Month(Date), Type:=1)

    If Not varMonth = False Then
      If varMonth > 0 And varMonth < 13 Then
        Redim varOut(0)
        varOut(0) = Array("RST ID", "Ktr", "Kto", "RST-Kto", "Dienstleister", "Dienstleister-Nr", "Beschreibung", "Betrag", "Leistungsmonat")
        For Each objWS In ThisWorkbook.Worksheets
          If objWS.Name Like "Tabelle*" Then
            With objWS
              varCol = Application.Match(Format(DateSerial(1, varMonth, 1), "MMMM"), .Rows(1), 0)
              If IsNumeric(varCol) Then
                For Each rng In .Range("W3:W" & Application.Max(3, .Cells(.Rows.Count, 23).End(xlUp).Row))
                  If rng <> "" Then
                    If InStr(1, rng.Text, "x") = 0 And .Cells(rng.Row, varCol) <> 0 Then
                      varTemp(0) = rng
                      varTemp(1) = .Cells(rng.Row, 1)
                      varTemp(2) = .Cells(rng.Row, 2)
                      varTemp(3) = .Cells(rng.Row, 7)
                      varTemp(4) = .Cells(rng.Row, 5)
                      varTemp(5) = .Cells(rng.Row, 6)
                      varTemp(6) = "RST - " & .Cells(rng.Row, 4) & " - " & .Cells(rng.Row, 5) & " - " & Format(DateSerial(Year(Date), varMonth, 1), "MM,yy")
                      varTemp(7) = .Cells(rng.Row, varCol)
                      varTemp(8) = Format(DateSerial(Year(Date), varMonth, 1), "MM,yy")
                      lngI = lngI + 1
                      Redim Preserve varOut(lngI)
                      varOut(lngI) = varTemp
                    End If
                  End If
                Next
              End If
            End With
          End If
        Next
        If lngI > 0 Then
          Set objWSNew = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
          With objWSNew
            strName = "RST " & Format(DateSerial(Year(Date), varMonth, 1), "MM,yy")
            Do While SheetExist(strName)
              lngN = lngN + 1
              strName = "RST " & Format(DateSerial(Year(Date), varMonth, 1), "MM,yy") & " (" & lngN & ")"
            Loop
            .Name = strName
            .Rows(1).Font.Bold = True
            .Rows(1).HorizontalAlignment = xlCenter
            Range("A1").Resize(lngI + 1, UBound(varTemp) + 1) = Application.Transpose(Application.Transpose(varOut))
            .Range("A1").AutoFilter
            .Columns.AutoFit
            For lngI = 1 To UBound(varTemp) + 1
              .Columns(lngI).ColumnWidth = .Columns(lngI).ColumnWidth + 5
              Select Case lngI
                Case 2 To 4, 6, 9
                  .Columns(lngI).HorizontalAlignment = xlCenter
                Case 8
                  .Columns(lngI).NumberFormat = "??0,0"
                Case Else
              End Select
            Next
          End With
          With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
            .Zoom = 85
          End With
        Else
          MsgBox "Es wurden keine Daten gefunden!", vbExclamation
        End If
      Else
        MsgBox "Ungültige Monatsangabe!", vbExclamation
      End If
    End If

    ErrorHandler:

    With Err
      If .Number <> 0 Then
        MsgBox "Fehler in Prozedur:" & vbTab & "'nn'" & vbLf & String(25, "—") & _
          vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
          "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
          .Description & vbLf, 81968, "VBA - Fehler in Prozedur - RST", .HelpFile, .HelpContext
        .Clear
      End If
    End With

    On Error GoTo 0

    With Application
      .ScreenUpdating = True
      .EnableEvents = True
      .Calculation = CalculationMode
      .DisplayAlerts = True
      .StatusBar = False
    End With

    Set rng = Nothing
    Set objWS = Nothing
    Set objWSNew = Nothing
    End Sub

    Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) 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 LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
    Next
    ErrorHandler:
    SheetExist = False
    End Function

    Gruß Sepp


    Bild

    Betrifft: AW: VBA - Daten aus mehreren in ein Tabellenblatt
    von: Josef
    Geschrieben am: 04.12.2015 08:13:58
    Wow, es funktioniert tadellos. Vielen Dank Sepp!
    Gruß
    Jupp

    Bild

    Betrifft: AW: VBA - Daten aus mehreren in ein Tabellenblatt
    von: Josef
    Geschrieben am: 04.12.2015 08:30:08
    Hallo nochmal,
    eine Frage hab ich aber noch.
    Die Quell-Tabellenblätter haben in ihrer eigentlichen Verwendung nicht den Namen "Tabelle1" etc., sondern andere.
    Die Zeile

    If objWS.Name Like "Tabelle*" Then
    lässt das Makro also abbrechen, wenn das der Fall ist.
    Was kann ich machen damit es auch mit anderen Namen geht?
    Gruß
    Josef

    Bild

    Betrifft: AW: VBA - Daten aus mehreren in ein Tabellenblatt
    von: Sepp
    Geschrieben am: 04.12.2015 08:48:19
    Hallo Josef,
    sollen alle Tabellen, außer evtl. vorhandenen 'RTS...' bearbeitet werden?
    Oder welche Tabellen sollen nicht berücksichtigt werden?
    Gruß Sepp

    Bild

    Betrifft: AW: VBA - Daten aus mehreren in ein Tabellenblatt
    von: Josef
    Geschrieben am: 04.12.2015 08:55:18
    Guten Morgen Sepp,
    Kann man es so einrichten, dass ausgeblendete Tabellen nicht berücksichtigt werden?
    Die endgültige Datei wird viele Tabellenblätter enthalten, auch welche ohne Quelldaten.
    Entweder lösche ich diese temporär vor der Makro-Durchführung oder ich blende sie aus.
    Eventuell vorhandene "RST..." sollen ignoriert werden.
    Danke und Grüßle
    Jupp

    Bild

    Betrifft: AW: VBA - Daten aus mehreren in ein Tabellenblatt
    von: Sepp
    Geschrieben am: 04.12.2015 09:13:25
    Hallo Josef,
    dann so.

    For Each objWS In ThisWorkbook.Worksheets
          If Not objWS.Name Like "RTS*" And objWS.Visible = xlSheetVisible Then
    
    Gruß Sepp

    Bild

    Betrifft: AW: VBA - Daten aus mehreren in ein Tabellenblatt
    von: Josef
    Geschrieben am: 04.12.2015 11:01:17
    Dankeschön Sepp, es funktioniert hervorragend.
    Gruß
    Jupp

    Bild

    Betrifft: bei 'Range("A1").Resize(....' fehlt ...
    von: Sepp
    Geschrieben am: 03.12.2015 17:35:13
    ... noch ein Punkt (.) davor!

    .Range("A1").Resize(...
    Gruß Sepp


    Bild

    Betrifft: Einfach alles auf einmal
    von: Michael
    Geschrieben am: 03.12.2015 20:57:31
    Hallo zusammen,
    ich habe mir gedacht, wozu Monate eingeben, wenn der Anwender doch bestimmt früher oder später sowieso alle haben will.
    Also auf Klick alles in einem Rutsch.
    Es gibt zwei Makros:
    - eines löscht alle (evtl. vorhandenen) Monatsblätter und legt sie neu an und
    - das zweite kopiert alle Daten aus den Tabellen in die Monatsblätter.
    Ich habe intensiven Gebrauch von Arrays gemacht, um die unterschiedliche Spaltenzuordnung und das eine oder andere zu managen.
    Der Code ist evtl. nicht ganz simpel zu lesen - ich habe ihn aber von vornherein so optimiert, daß er ratz-fatz arbeitet: unter 20 ms für alles (auf meiner Maschine) ist doch nicht schlecht.
    Die Datei: https://www.herber.de/bbs/user/101993.xlsm
    Schöne Grüße,
    Michael

     Bild

    Beiträge aus den Excel-Beispielen zum Thema "VBA - Daten aus mehreren in ein Tabellenblatt"