Inhalt zweier Tabellen in einer zusammenfassen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Gregor!
Ungetestet!

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

Option Explicit

Sub ZweiInEins()
Dim objWS1 As Worksheet, objWS2 As Worksheet
Dim varSheets As Variant
Dim rng As Range
Dim lngLast As Long, lngRow As Long
Dim intIndex As Integer

varSheets = Array("Tabelle1", "Tabelle2") ' Namen der Quelltabellen - Namen anpassen!

Set objWS1 = Sheets("Tabelle3") ' Zieltabelle - Name anpassen!

objWS1.Range("A2:IV65536").Clear ' Ab Zeile 2 - erste Zeile Überschriften!

For intIndex = 0 To UBound(varSheets)

  Set objWS2 = Sheets(varSheets(intIndex))

  With objWS2

    lngLast = .Cells(Rows.Count, 1).End(xlUp).Row

    For lngRow = 2 To lngLast ' Ab Zeile 2 - erste Zeile Überschriften!
      If Application.CountA(.Rows(lngRow)) > 0 Then
        If rng Is Nothing Then
          Set rng = .Rows(lngRow)
        Else
          Set rng = Union(rng, .Rows(lngRow))
        End If
      End If
    Next

    If Not rng Is Nothing Then
      rng.Copy objWS1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
      Set rng = Nothing
    End If

  End With

  Set objWS2 = Nothing

Next

Set objWS1 = Nothing

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Gregor!
Davon stand aber nichts in deiner ursprünglichen Frage!
Als Ansatz, weiter ausbauen kannst du es selber!

' **********************************************************************
' Modul: Tabelle3 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub CommandButton1_Click()
Dim objWS1 As Worksheet, objWS2 As Worksheet
Dim varSheets As Variant
Dim rng As Range
Dim lngLast As Long, lngRow As Long
Dim lngIndex As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlCalculationManual
End With

varSheets = Array("Offen", "Bezahlt") ' Namen der Quelltabellen - Namen anpassen!

Set objWS1 = Sheets("Alle") ' Zieltabelle - Name anpassen!

objWS1.Range("A2:IV65536").Clear ' Ab Zeile 2 - erste Zeile Überschriften!

For lngIndex = 0 To UBound(varSheets)

  Set objWS2 = Sheets(varSheets(lngIndex))

  With objWS2

    lngLast = .Cells(Rows.Count, 1).End(xlUp).Row

    For lngRow = 2 To lngLast ' Ab Zeile 2 - erste Zeile Überschriften!
      If Application.CountA(.Rows(lngRow)) > 0 Then
        If rng Is Nothing Then
          Set rng = .Rows(lngRow)
        Else
          Set rng = Union(rng, .Rows(lngRow))
        End If
      End If
    Next

    If Not rng Is Nothing Then
      rng.Copy objWS1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
      Set rng = Nothing
    End If

  End With

  Set objWS2 = Nothing

Next

Set rng = Nothing

With objWS1
  lngLast = .Cells(Rows.Count, 1).End(xlUp).Row
  lngIndex = 2

  .Range("A1:I" & lngLast).Sort key1:=.Range("B1"), key2:=.Range("C1"), Header:=xlGuess

  lngRow = 2
  Do

    If .Cells(lngRow + 1, 2) <> .Cells(lngRow, 2) Or .Cells(lngRow + 1, 2) = "" Then
      .Range(.Cells(lngRow + 1, 1), .Cells(lngRow + 1, 9)).Insert
      .Cells(lngRow + 1, 3) = "SUMME"
      .Cells(lngRow + 1, 4) = .Cells(lngRow, 2)
      .Cells(lngRow + 1, 5) = Application.Sum(.Range(.Cells(lngIndex, 5), .Cells(lngRow, 5)))
      .Cells(lngRow + 1, 5).NumberFormat = "#,##0.00 $"
      .Cells(lngRow + 1, 7) = Application.Sum(.Range(.Cells(lngIndex, 7), .Cells(lngRow, 7)))
      .Cells(lngRow + 1, 7).NumberFormat = "#,##0.00 $"
      .Cells(lngRow + 1, 8) = Application.Sum(.Range(.Cells(lngIndex, 8), .Cells(lngRow, 8)))
      .Cells(lngRow + 1, 8).NumberFormat = "#,##0.00 $"
      .Range(.Cells(lngRow + 1, 3), .Cells(lngRow + 1, 8)).Font.Size = 10

      If rng Is Nothing Then
        Set rng = .Range(.Cells(lngIndex, 5), .Cells(lngRow, 5))
      Else
        Set rng = Union(rng, .Range(.Cells(lngIndex, 5), .Cells(lngRow, 5)))
      End If

      With .Range(.Cells(lngRow + 1, 1), .Cells(lngRow + 1, 9))
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
      End With

      With .Range(.Cells(lngRow + 1, 3), .Cells(lngRow + 1, 8))
        .Interior.ColorIndex = 36
        With .Borders(xlEdgeLeft)
          .LineStyle = xlContinuous
          .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
          .LineStyle = xlContinuous
          .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
          .LineStyle = xlContinuous
          .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
          .LineStyle = xlContinuous
          .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
          .LineStyle = xlContinuous
          .Weight = xlThin
        End With
      End With

      lngIndex = lngRow + 2
      lngRow = lngRow + 1
    End If
    lngRow = lngRow + 1

  Loop While lngRow < .Cells(Rows.Count, 2).End(xlUp).Row + 1

  lngRow = lngRow + 4

  .Cells(lngRow, 3) = "SUMME"
  Cells(lngRow, 3).Font.Bold = True
  .Cells(lngRow, 5) = Application.Sum(rng)
  .Cells(lngRow, 5).NumberFormat = "#,##0.00 $"
  .Cells(lngRow, 7) = Application.Sum(rng.Offset(0, 2))
  .Cells(lngRow, 7).NumberFormat = "#,##0.00 $"
  .Cells(lngRow, 8) = Application.Sum(rng.Offset(0, 3))
  .Cells(lngRow, 8).NumberFormat = "#,##0.00 $"
  .Range(.Cells(lngRow, 3), .Cells(lngRow, 8)).Font.Size = 10

  With .Range(.Cells(lngRow, 1), .Cells(lngRow, 9))
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
  End With

  With .Range(.Cells(lngRow, 3), .Cells(lngRow, 8))
    .Interior.ColorIndex = 36
    With .Borders(xlEdgeLeft)
      .LineStyle = xlContinuous
      .Weight = xlMedium
    End With
    With .Borders(xlEdgeTop)
      .LineStyle = xlContinuous
      .Weight = xlMedium
    End With
    With .Borders(xlEdgeBottom)
      .LineStyle = xlContinuous
      .Weight = xlMedium
    End With
    With .Borders(xlEdgeRight)
      .LineStyle = xlContinuous
      .Weight = xlMedium
    End With
    With .Borders(xlInsideVertical)
      .LineStyle = xlContinuous
      .Weight = xlThin
    End With
  End With

End With

Set objWS1 = Nothing

ErrExit:

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

Inhalt zweier Tabellen in einer zusammenfassen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Inhalt zweier Tabellen in einer zusammenfassen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread