VBA - Daten aus mehreren in ein Tabellenblatt

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Beliebteste Forumthreads (12 Monate)

VBA - Daten aus mehreren in ein Tabellenblatt

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

330 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA - Daten aus mehreren in ein Tabellenblatt

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

330 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread