Anzeige
Archiv - Navigation
712to716
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
712to716
712to716
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhalt zweier Tabellen in einer zusammenfassen
05.01.2006 23:35:58
Gregor
Hallo,
ich habe zwei Tabellen mit Daten
ich möchte das die gefüllten Zeilen beider Tabellen
in einer dritten untereinander stehen.
Da sich die Daten in den Tabellen ändern, es komen auch welche hinzu,
soll die dritte (Zusammenfassung) regelmäßig aktuallisiert werden,
neue hinzu und Äderungen abgleichen
oder einfach das Makro alle Zeilen die Inhalte haben aus Tabelle 1 und 2
in Tabelle 3, geht das mit Excel ?
Gregor
Ich habe unter Recherge "Zusammenfassen" nichts passendes gefunden.

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

Betreff
Datum
Anwender
Anzeige
AW: Inhalt zweier Tabellen in einer zusammenfassen
06.01.2006 00:06:45
Josef
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!
'******************************

Anzeige
Zwischensumme
06.01.2006 00:43:04
Gregor
Hallo Josef
Danke,
das ist super
Ich brauche allerdings auch noch das Ergebniss in der Zusammenfassung eine
Sortierung nach Nahmen, mit jeweils Zwischensummen:
---------------------------------------------------------------------------------------
0 Kreditor Re.Datum Infos Mwst.-Betrag Mwst. Netto Brutto
39 Dieter 07.11.2005 test 81,60 € 16 % 510,00 € 591,60 €
SUMME Dieter 81,60 510,00 591,60
38 Günter 16.11.2005 test 68,97 € 16 % 431,03 € 500,00 €
SUMME Günter 68,97 431,03 500,00
40 Heinz 04.11.2005 test 18,05 € 16 % 112,80 € 130,85 €
42 Heinz 30.12.2005 test 27,59 € 16 % 172,41 € 200,00 €
41 Heinz 30.12.2005 test 27,59 € 16 % 172,41 € 200,00 €
SUMME Heinz 73,22 457,63 530,85
1 mannfred 15.07.2005 test 27,86 € 16 % 174,14 € 202,00 €
SUMME mannfred 27,86 174,14 202,00
0 test 0,00 € 16 % 0,00 € - €
SUMME test 0,00 0,00 0,00
0,00 € 16 % 0,00 €
0,00 € 16 % 0,00 €
SUMME 251,65 1572,80 1824,45
-------------------------------------------------------------------------------------
Muster, Tabelle "Alle(2)"
https://www.herber.de/bbs/user/29767.xls
Wozu dient eigentlich: Option Explicit
Gregor
Anzeige
Option Explicit
06.01.2006 01:04:08
Gregor
Hi Salut,
wissen macht ah
Danke für den Link,
jetzt weis ich wieder etwas mehr.
Gregor
AW: Zwischensumme
06.01.2006 02:07:20
Josef
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!
'******************************

Anzeige
AW: Zwischensumme
06.01.2006 07:58:12
Gregor
Danke Josef,
ich wollte die Fragestellung nicht zu umfangreich machen
und nicht mehrere Frage zugleich stellen.
Aber ich danke dir vielmals für diese Lösung,
funktioniert super.
Gregor

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige