Tabellenblätter zusammenführen

Bild

Betrifft: Tabellenblätter zusammenführen
von: DieterG
Geschrieben am: 20.11.2015 17:00:20

Hallo zusammen,
ich bräuchte mal wieder Eurer Hilfe.
Ich habe eine Excel Datei mit 13 Tabellenblättern "Jan-Dez". Die Tabellen sind alle identisch aufgebaut.
Aufgabenstellung:
Die Daten aus den 12 Blättern "Jan-Dez" sollen in einem separaten Tabellenblatt untereinander zusammengeführt werden. Das 13 Blatt soll dabei nicht berücksichtigt werden!
Die Daten sollten ab Zeile 7 und aus den Spalten H,I,L ausgelesen und untereinander in den Spalten A,B,C zusammengeführt werden.
Vielen Danke für die Mühe!
Gruß
Dieter

Bild

Betrifft: AW: Tabellenblätter zusammenführen
von: Bernd
Geschrieben am: 21.11.2015 06:09:02
Hi,
habs im Netz gefunden, zwar noch nicht ganz perfekt für Dich, aber bei VBA Bescheiden, sollte es für Dich als Vorlage dienen, welche dann eben dementsprechend geändert gehört:
Option Explicit
Const ListDaten = "Alle Daten" 'Tabellenblatt Alle Daten
Const CopyRng = "H7" 'Kopieren Zelle 1
Const CopyBeg = "H" 'Kopieren Spalte 1
Const CopyEnd = "L" 'Kopieren Spalte n
Const ListId = "A" 'Alle Daten Spalte Lfd-Nr.
Const ListName = "B" 'Alle Daten Spalte Tabellenname
Const ListPaste = "C" 'Alle Daten Spalte Datenkopie
Sub InitDaten()
Dim Wks As Worksheet, Found As Object, NextLine As Integer, Id As Integer

Call InitListSheet

Application.ScreenUpdating = False

For Each Wks In Worksheets
If Wks.Name <> ActiveSheet.Name Then
Set Found = Columns(ListName).Find(Wks.Name, LookIn:=xlValues, LookAt:=xlWhole)
If Found Is Nothing And Not IsEmpty(Wks.Range(CopyRng)) Then
NextLine = GetEndLine(ActiveSheet, ListPaste) + 1
Cells(NextLine, ListId) = GetNextId(): Cells(NextLine, ListName) = Wks.Name
Range(Wks.Range(CopyRng), Wks.Cells(GetEndLine(Wks, CopyBeg), CopyEnd)).Copy
ActiveSheet.Paste Destination:=Cells(NextLine, ListPaste)
Application.CutCopyMode = False
End If
End If
Next
Application.ScreenUpdating = True
End Sub

Private Sub InitListSheet()
    Dim Wks As Worksheet
    
    On Error Resume Next:  Set Wks = Sheets(ListDaten):  On Error GoTo 0
    
    If Wks Is Nothing Then
        Sheets.Add Before:=Sheets(1):  ActiveSheet.Name = ListDaten
        With Range("A1")
            .Value = Array("Ergebnis")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.FontStyle = "Fett"
        End With
    Else
        Wks.Activate
    End If
End Sub

Private Function GetEndLine(ByRef Wks, Col As String) As Integer
    GetEndLine = Wks.Cells(Wks.Rows.Count, Col).End(xlUp).Row
End Function

Private Function GetNextId() As Integer
    Dim EndLine As Integer
    EndLine = GetEndLine(ActiveSheet, ListId)
    If EndLine = 1 Then GetNextId = 1 Else GetNextId = Cells(EndLine, ListId) + 1
End Function

mfg Bernd

Bild

Betrifft: AW: Tabellenblätter zusammenführen
von: DieterG
Geschrieben am: 21.11.2015 06:38:00
Hallo Bernd,
Danke für die Mühe, aber ich glaube da hab ich mich falsche eingeschätzt. Dafür reichen meine VBA-Kenntnisse leider nicht aus.
Gruß
Dieter

Bild

Betrifft: AW: Bsp.-Mappe
von: hary
Geschrieben am: 21.11.2015 08:46:13
Moin Dieter
Sind die Spalten H,I,L ab Zeile 7 immer gleich lang?
In welches Blatt soll kopiert werden?
Eine Bsp.-Mappe mit Zielblatt und 2 Monaten wuerde helfen.
gruss hary

Bild

Betrifft: AW: Bsp.-Mappe
von: DieterG
Geschrieben am: 21.11.2015 10:15:19
Hallo Hary,
hier die Bsp.-Mappe
https://www.herber.de/bbs/user/101689.xlsx
- Die Spalten können unterschiedlich lang sein.
- Die Daten in den gelb markierten Spalten sollen in das Zielblatt "Auswertung" ab Zeile3 kopiert werden.
Danke schon mal!
Gruß Dieter

Bild

Betrifft: AW: Bsp.-Mappe
von: hary
Geschrieben am: 21.11.2015 10:45:17
Moin
Was ist mit den leeren Blaettern? Da ist noch klaerungsbedarf.
Code in ein Modul.

Sub Uebertragen()
Dim letzte As Long
Dim naechste As Long
Dim mySheets, oSH As Object
Dim wksZ As Worksheet
  Set wksZ = Worksheets("Auswertung")
  Set mySheets = Sheets(Array("Januar", "Februar", "März", "April", "Mai", "Juni", "Juli", " _
August", _
                            "September", "Oktober", "November", "Dezember"))
  For Each oSH In mySheets
    naechste = Application.Max(3, wksZ.Cells(Rows.Count, 1).End(xlUp).Row + 1)
      With oSH
       If .Cells(7, 2) <> "" Then
        letzte = .Cells(Rows.Count, 2).End(xlUp).Row
         Union(.Cells(7, 5).Resize(letzte - 6, 1), .Cells(7, 8).Resize(letzte - 6, 2), .Cells(7, _
 12).Resize(letzte - 6, 1)).Copy wksZ.Cells(naechste, 1)
       End If
      End With
  Next oSH
  Set wksZ = Nothing
  Set mySheets = Nothing
End Sub

gruss hary

Bild

Betrifft: AW: Bsp.-Mappe
von: DieterG
Geschrieben am: 21.11.2015 11:19:22
Hallo Hary,
die Blätter werden nach und nach ausgefüllt, wenn also in einem Blatt ab Zeile7 keine Daten eingetragen sind brauchen diese nicht mit kopiert werden.
Gruß Dieter

Bild

Betrifft: AW:Nachgefragt
von: hary
Geschrieben am: 21.11.2015 11:36:39
Moin
Jepp ist klar, dann gehts weiter. ;-))
Wann moechtest du uebertragen?? Alle Blaetter? oder nur das gerade Aktive?
Koennen in den Blaettern im nachhinein noch Eintragungen gemacht werden??
Du musst genau beschreiben wann uebertragen werden soll.
gruss hary

Bild

Betrifft: AW: AW:Nachgefragt-
von: DieterG
Geschrieben am: 21.11.2015 14:31:07
Hallo Hary,
Die Daten können ständig erweitert werden. Es müssen immer alle Blätter kopiert werden. Bevor neu ausgewertet wird, müssen die alten Daten vorher gelöscht werden. Gestartet wird mit einem Button im Blatt Auswertung.
Gruß D.

Bild

Betrifft: AW:Mappe zurueck
von: hary
Geschrieben am: 21.11.2015 18:00:27
Moin Dieter
Biddeschoen, Button ist in "Auswertung"
https://www.herber.de/bbs/user/101706.xlsm
gruss hary

Bild

Betrifft: Danke
von: DieterG
Geschrieben am: 21.11.2015 18:28:58
Hallo Hary,
du bist echt genial, das funktioniert genauso wie ich es mir vorgestellt habe.
Vielen Dank nochmal für deine Mühe und Zeit!
Gruß Dieter

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Tabellenblätter zusammenführen"