132183
Goto Top

Tabellenblätter zusammenfassen und Kennzeichnen

Hallo an alle ich würde etwas Hilfe brauchen

Ich würde gerne über eine Taste "Aktualisieren" bestimmte Tabellenblätter zusammenfassen hab aber leider keine Ahnung wie ich das anstellen soll.

Folgendes müsste passieren:
  • Der Inhalt des Tab "Zusammenfassung" Zeile 3 bis x müsste gelöscht werden.
  • Der Inhalt von Bestimmte Tab's, jeweils Zeile 3 bis x , sollen auf Tab: "Zusammenfassung" eingetragen werden und in jeder eingetragenen Zeile sollte in Spalte O der Name des Herkunftstabellenblatt stehen und in Spalte N die Zeilen Nr. unter der dieser Datensatz dort zu finden ist. Bsp. Tab: "KW3" Zeile: "124"
  • Zuerst soll das Tab: "Zusammenfassung Alt" übertragen werden.
  • Die restlichen zu übertragenen Tab's sind jeweils mit "KW1" , "KW2", usw. benannt, alle Tab's die in die Zusammenfassung kommen sind gleich aufgebaut. Irgendwann kommt das Tab: "Übersicht", dieses und die folgenden Tab's kommen dann nicht mehr in die Zusammenfassung hinein. Sie sind auch anders aufgebaut.

Aufbau der zu übertragenen Tabellenblätter:
  • Der Aufbau ist immer gleich: Überschrift ist in Zeile 2, Spalte A bis M. Die Zeilenanzahl Variiert.

Sonstiges:
  • Die Tab "Zusammenfassung Alt" und "Zusammenfassung" sind mit einem Schreibschutz versehen. In der Bsp. Mappe ist natürlich kein Kennwort vergeben.

Ich möchte es dann anschließend über die Auswahl einer Zeile und eine zusätzliche Schaltfläche ("gehe zu") von der Zusammenfassung in das Tab und die Zeile des gewählten Datensatzes springen. Deswegen auch diese Beschriftung.

Option Explicit
Sub Zusammenfassung_Aktualisiere_Klick()

Dim wsZusam As Worksheet
Dim wsZusamAlt As Worksheet
Dim wsKW As Worksheet
Dim i As Integer
Dim k As Integer
Set wsZusam = ThisWorkbook.Sheets("Zusammenfassung")  
Set wsZusamAlt = ThisWorkbook.Sheets("Zusammenfassung Alt")  
'Set wsKW = ???????????  

wsZusam.Unprotect Password:=""  
wsZusamAlt.Unprotect Password:=""  

**???????**

wsZusam.Protect Password:=""  
wsZusamAlt.Protect Password:=""  
Set wsZusam = Nothing
Set wsZusamAlt = Nothing
'Set wsKW = Nothing  
End Sub

Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
    ' Ermittelt die letzte beschriebene Zeile  
    On Error Resume Next
    LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row  
End Function

Public Function LetzteBeschriebeneSpalte(ByRef rngBereich As Range) As Long
 ' Ermittelt die letzte beschriebene Spalte  
    On Error Resume Next
    LetzteBeschriebeneSpalte = rngBereich.Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious).Column  
End Function
Bsp Mappe: V1.0 Tabellenblätter zusammenführen.xlsm

Ich hoffe ihr könnt mir weiterhelfen. Vielen Dank
Grüße Semmy

Content-Key: 341582

Url: https://administrator.de/contentid/341582

Ausgedruckt am: 19.03.2024 um 05:03 Uhr

Mitglied: 133417
133417 24.06.2017 aktualisiert um 14:48:44 Uhr
Goto Top
Ola.
Ich hoffe ihr könnt mir weiterhelfen.
Klar, kein Problem, halbe Stunde Programmierarbeit inkl. Einlesen, 80 Ocken + Märchensteuer bist du dabei.

Gruß
Mitglied: 132183
132183 25.06.2017 um 10:38:50 Uhr
Goto Top
Hallo

Klar, kein Problem, halbe Stunde Programmierarbeit inkl. Einlesen, 80 Ocken + Märchensteuer bist du dabei.
Danke für das Angebot aber 80 sind mir etwas zu teuer. (Ich müsst das nämlich aus eigener Tasche zahlen.)

Grüße Semmy
Mitglied: 133417
133417 25.06.2017 aktualisiert um 13:19:52 Uhr
Goto Top
Und was bist du bereit für die "Auftragsarbeit" die du hier den Usern auftischst hinzulegen? Liegt hier fertig, wenn du also willst, PN ...

Sowas wäre sowieso eigentlich eher etwas für eine Datenbank wie Access & Co.
Mitglied: 132183
132183 25.06.2017 aktualisiert um 13:57:15 Uhr
Goto Top
Hallo

Also ich hab mittlerweile schon ein wenig was mit Hilfe von Google zusammen bekommen. Allerdings würde ich Hilfe brauchen um das jetzt so zu ergänzen, damit es tut was ich will.

Im Moment fehlt mir noch:
  • Der Tabellenblatt Name und die Zeilennummer des jeweiligen Datensatzes müssen im Tab „Zusammenfassung“ rechts daneben geschrieben werden.
  • Im Moment fast das Makro noch alle Tab's zusammen. Es sollen aber nur die Tabs erfasst werden die mit KW beginnen bzw. die Tab's bis zum Tabellenblatt "Übersicht". Plus das Tab "Zusammenfassung Alt", wäre gut wenn dieses als erstes verarbeitet wird.

Derzeitiger Code:
Option Explicit

Sub Zusammenfassung_Aktualisiere_Klick()
' Uebertragen der Werte aus allen Blaettern einer Mappe eine Uebersicht  
' abhängig von der Menge der Daten - ein oder zwei Seiten  
'  
' Veraendertes Vorgehen:  
'               - Information ueber die Anzahl der in den Blaettern vorhandenen Saetze  
'               - die Saetze der Haelfte der Blaetter werden  
'                   auf je einem Blatt zusammengefasst  
'               - Es findet keine Zuschreibung statt - der Bereich auf dem ersten Blatt  
'                   wird vor Ausfuehrung des Makros geloescht, so dass nur noch die  
'                   Ueberschriften auf der Seite verbleiben  
'  
Dim Sh As Worksheet            ' Festlegung Arbeitsblatt  
Dim Wahlbool As Boolean     ' Variable zur Entscheidung der Aufteilung auf Blaetter  
Dim Uebersicht1 As String    ' Zweites Blatt fuer die Uebersicht  
Dim Wahl As String                ' Auswahlmoeglichkeit fuer Vorgehen bei nicht ausreichendem   
                              'Platz auf der Seite Uebersicht  
Dim BlattName As String      ' Variable zur Bestimmung des aufnehmenden Blattes  
Dim intRow As Long              ' Festlegung Zeilenanzahl fuer Uebergabe  
Dim intRowS As Long            ' genutzte Zeilenanzahl  
Dim j As Integer                      ' genutzte Zeilen in den Blaettern  
Dim jr As Long                        ' genutzte Spalten in den Blaettern  
Dim zaehler As Long             ' Anzahl der freien Zeilen  
Dim intsh As Integer              ' Blattzaehler fuer die Splittung aus zwei Uebersichtsblaetter  
Dim intAnz As Integer           ' Anzahl der in der Mappe vorhandenen Blaetter  
Dim Here As Variant
Dim MyColumn As Variant
Dim Jc As Long
'  
Const Fest = 2                  ' hier die Anzahl der "festen" Zeilen in jedem Blatt angeben;  
Const Fest1 = 2                 ' Wert der "festen" Zeilen auf der Uebersichtsseite  
Const Uebersicht = "Zusammenfassung"   ' hier den Namen der Uebersicht veraendern  
'  
'*** Beginn der Programmes - hier Ueberpruefung ***  
'  
' Bildschirmaktualisierung aus  
Application.ScreenUpdating = False
'  
' Festlegen der weiteren Angaben  
Uebersicht1 = Uebersicht & "1"      ' Vergabe des Namens fuer das zweite Blatt  
Wahlbool = False                    ' Generell erfolgt nur Zusammenfassung auf ein Blatt  
intsh = 0                           ' Zaehler fuer Zusammenfassung  
intAnz = Worksheets.Count           ' Anzahl der in Mappe vorhandenen Blaetter  
intAnz = Int(intAnz / 2)            ' Ganzzahliger Teil der Haelfte der Blaetter  
'  
' Fehlerkorrektur, wenn zweites Blatt fuer Uebersicht nicht existiert  
On Error GoTo Weiter
' Loeschen des zweiten Blattes der Uebersicht und Anzeige per MsgBox  
Application.DisplayAlerts = False
Sheets(Uebersicht & "1").Delete  
Application.DisplayAlerts = True
MsgBox "Blatt wurde geloescht!"     ' kann ausgelassen werden  
'  
' Sprungmarke fuer den Fall, dass zweites Blatt nicht existiert  
Weiter:
'  
' Abfangen durch eine Fehlerkorrektur, wenn Blattname nicht vorhanden  
On Error GoTo ErrorBlattName
'  
' Ueberpruefen des freien Raumes zum Kopieren  
' Schritt 1: Feststellen der Anzahl der Saetze  
For Each Sh In Sheets
    If Sh.Name <> Uebersicht Then
    Sh.Activate
    jr = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    zaehler = zaehler + jr - Fest
    End If
Next
' Schritt 2: Freier Platz auf der Uebersicht  
Sheets(Uebersicht).Activate
intRowS = Cells(Cells.Rows.Count, 1).End(xlUp).Row
intRow = 65536 - intRowS - Fest1
'  
' Bei nicht ausreichendem Platz erfolgt Mitteilung und weitere Wahl durch User  
If zaehler > intRow Then
MsgBox "Das Zusammenfuehren der Datensaetze " & Chr(13) & _  
    "kann nicht auf einem Blatt erfolgen." & Chr(13) & _  
    Chr(13) & "In den zu kopierenden Blaettern befinden sich " & Chr(13) & _  
    "insgesamt " & zaehler & " Saetze." & Chr(13) & Chr(13) & _  
    "Verbleibende Zellen auf Uebersicht: " & intRow  

' Wahlmoeglichkeit des Users: Aufteilen oder Abbrechen  
Wahl = MsgBox("Sie haben die Wahl: " & Chr(13) & Chr(13) & _  
    "Wenn die Aufteilung auf zwei Seiten erfolgen soll: OK" & _  
    Chr(13) & "Wenn beendet werden soll: ABBRUCH", vbOKCancel)  
'Auswertung der Schaltflaechen  
    Select Case Wahl
        Case vbOK

    ' Einfuegen eines neuen Blattes, umbenennen und kopieren der Kopfangaben  
    ' Setzen der Variablen fuer das Kopieren auf zwei Blaetter  
            Sheets.Add after:=Sheets(Uebersicht)
            ActiveSheet.Name = Uebersicht & "1"  
            Sheets(Uebersicht).Activate
            Range("A1:CZ" & Fest1).Copy  
            Sheets(Uebersicht & "1").Activate  
            Range("a1").Select  
            Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
                , Transpose:=False
            Wahlbool = True
        Case vbCancel
    ' Abbruch auf Wunsch  
        MsgBox "Der Vorgang wird auf Ihren Wunsch beendet.", vbInformation  
        GoTo Beenden
    End Select
End If
'  
' Abfangen durch eine Fehlerkorrektur, wenn anderer Fehler  
On Error GoTo ErrorAndererFehler
'  
'*** Ab hier  beginnt die Verarbeitung ***  
'  
' Loeschen des Inhaltes auf dem Blatt Uebersicht  
' hier: Loeschen der Zeilen und Verschieben nach oben  
'  
Sheets(Uebersicht).Activate
' Sollten die Daten nicht in der zweiten Zeile beginnen,  
' ist die jeweilige Startzeile entsprechend zu veraendern  
Rows((Fest1 + 1) & ":" & intRowS).Delete Shift:=(xlUp)  
'  
For Each Sh In Sheets
    If Sh.Name <> Uebersicht Then
        If Sh.Name <> Uebersicht & "1" Then  
' Feststellen der genutzten Zeilen und Spalten  
' Feststellen der Adresse der letzten Spalte (Buchstabe)  
    intsh = intsh + 1
    If Wahlbool Then
        If intsh <= intAnz Then
        BlattName = Uebersicht
        Else
        BlattName = Uebersicht & "1"  
        End If
    Else
    BlattName = Uebersicht
    End If
    Sh.Activate
    jr = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    Jc = ActiveSheet.UsedRange.Columns.Count            ' wenn Spalten geloescht werden,  
                                                        ' muss die Mappe entweder gespeichert  
                                                        ' werden oder analog zur Ermittlung  
                                                        ' der Zeilen vorgegangen werden  
    Here = Cells(1, Jc).Address
    MyColumn = Mid(Here, InStr(Here, "$") + 1, _  
    InStr(2, Here, "$") - 2)  
'  
' Kopie der beschriebenen Bereiche  
        Range("A" & Fest + 1 & ":" & MyColumn & jr).Select  
        Selection.Copy
'  
' Uebertragen der Daten und Einfügen ins Blatt Uebersicht nach Abhängigkeit  
        Sheets(BlattName).Select
' Feststellen des Einfügebereiches  
    intRowS = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    If IsEmpty(Range("A1")) Then  
        intRow = 1
    Else
        intRow = intRowS + 1
    End If
        Range("A" & intRow).Select  
' Einfügen ins Blatt Uebersicht  
        ActiveSheet.Paste
        Range("A" & Fest1 + 1).Select  
        Sh.Activate
        Range("A" & Fest + 1).Select  
    End If
    End If
    Next
'  
'*** Normales Ende der Prozedur ***  
'  
Beenden:
    Sheets(Uebersicht).Activate
    Range("A" & Fest1 + 1).Select  
    Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub
'  
'*** Fehlerbehandlungen ***  
'  
'/// Falscher Blattname  
ErrorBlattName:
MsgBox "Fehler! Der Blattname existiert nicht!" & Chr(13) & _  
    Chr(13) & "Vorgang wird beendet.", vbCritical  
Range("A" & Fest1 + 1).Select  
GoTo Beenden
'  
'/// AndererFehler  
ErrorAndererFehler:
MsgBox "Fehler! Der Schreiber des Makros hat einen" & Chr(13) & _  
    "fatalen Denkfehler begangen!" & Chr(13) & Chr(13) & _  
    "Schreiben Sie ihm ihre Meinung!" & Chr(13) & _  
    Chr(13) & "Der Vorgang wird beendet.", vbExclamation  
Range("A" & Fest1 + 1).Select  
GoTo Beenden

End Sub

Bsp. Mappe mit derzeitigen Code: V1.2 Tabellenblätter Zusammenführen

Könnt echt ein paar Tipps gebrauchen

Grüße Semmy
Mitglied: 133417
Lösung 133417 25.06.2017 aktualisiert um 14:17:11 Uhr
Goto Top
Wow, viele Zeilen für eigentlich wenig Arbeit face-smile da reichen auch 42 Zeilen oder weniger >>> https://we.tl/vEdedGnTgD
Und einen extra Button braucht es auch nicht wenn man dafür gleich einen Hyperlink in die Zellen setzt face-wink
Alles in allem sehr umständlich gelöst.
Mitglied: 132183
132183 25.06.2017 aktualisiert um 15:51:51 Uhr
Goto Top
O manface-surprise, bei mir sind es fast 200 Zeilen. Ok, alles klar, so geht es also auch. face-smile (ich bin ein Idiot)

Eine frage hätte ich da aber: Wenn es irgendwann sehr viele Datensätze sind Bläht sich dann so eine Datei nicht sehr auf, durch die Links. Ich meine von der größe der Datei her oder macht das keinen Unterschied?

Danke auf jeden fall für die Lernstunde (kann immer noch nicht glauben face-surprise)

Grüße Semmy
Mitglied: 133417
133417 25.06.2017 aktualisiert um 17:14:29 Uhr
Goto Top
Zitat von @132183:
Eine frage hätte ich da aber: Wenn es irgendwann sehr viele Datensätze sind Bläht sich dann so eine Datei nicht sehr auf, durch die Links. Ich meine von der größe der Datei her oder macht das keinen Unterschied?
Die Links machen nichts. Das das was du oben haben wolltest redundanter Müll ist habe ich ja schon zwei mal geschrieben, und das man für sowas eine einfache klassische Datenbank hernimmt.
Per VBA kannst du sehr schön Datensätze suchen, also Eingabemaske für Suchfelder designen, per VBA suchen und nur das Ergebnis ausgeben lassen wäre hier zuielgerichteter als die Daten allesamt jedes mal neu in das Sheet zu kopieren.
Danke auf jeden fall für die Lernstunde (kann immer noch nicht glauben face-surprise)
Bidde.