kopierten Daten einen Text anfügen
12.04.2019 13:29:45
Fred
ich habe im Netz ein VBA-Code gezogen und den soweit meinen Möglichkeiten angepasst.
Es werden aus allen Tabellenblättern der Mappe gefilterte Daten in Tabelle "Zusammenfassung" kopiert.
Im Ergebnis stehen dann die Daten in "Zusammenfassung" von "A3" bis "J"
Sub Zusammenfassung()
Application.Calculation = xlCalculationManual
'Es werden die Daten aller Tabellenblätter innerhalb einer Datei auf einem neuen Tabellenblatt _
_
_
gelistet.
'die Daten stehen ab Zeile 9
' Die Anzahl der Zeilen _
_
spielt keine Rolle.
'Ein Tabellenblatt mit dem Namen "Zusammenfassung" wird, wenn nicht bereits vorhanden, ganz _
links erstellt.
Dim wks As Worksheet 'Tabelle Zusammenfassung
Dim intSh As Integer 'Zähler für Tabelle1 bis TabelleX
Dim intLastS As Integer 'Letzte benutzte Spalte in den Tabellen
Dim bln As Boolean
Dim wksGefiltert As Worksheet
Dim LZ As Long
Set wksGefiltert = Worksheets("Zusammenfassung")
Worksheets("Zusammenfassung").Activate
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
With wksGefiltert
LZ = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Rows(4), .Rows(Application.WorksheetFunction.Max(2, LZ))).Delete 'löscht nach Zeile3 _
_
_
alle Zeilen
End With
'Prüfung ob Blatt "Zusammenfassung" bereits vorhanden ist.
For intSh = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(intSh).Name = "Zusammenfassung" Then
Set wks = Worksheets("Zusammenfassung")
bln = True
Exit For
End If
Next
'Falls nicht vorhanden dann erstellen
If bln = False Then
Set wks = Worksheets.Add
wks.Name = "Zusammenfassung"
End If
'Blatt Zusammenfassung nach links schieben
wks.Move Before:=Sheets(1)
'Daten auf Blatt "Zusammenfassung" löschen und die Überschrift aus Tabelle1 holen
'Anzahl der Spalten zählen. Gilt dann für alle Blätter da Aufbau identisch sein muss
wks.Range("A3:J20").ClearContents
Worksheets(2).Rows(1).Copy Destination:=wks.Range("A1")
intLastS = wks.Cells(1, Columns.Count).End(xlToLeft).Column - 38
'meine gefilterten Daten aus allen Tabellen nach Tabelle "Zusammenfassung" übertragen
For intSh = 2 To ActiveWorkbook.Worksheets.Count
With Worksheets(intSh)
.Range(.Cells(9, 1), .Cells(fncLastRow(intSh, intLastS), intLastS)).SpecialCells( _
xlCellTypeVisible).Copy
wks.Cells(wks.UsedRange.Rows.Count, 1).Offset(1, 0).PasteSpecial Paste:=xlValues
End With
Next
Application.CutCopyMode = False
MsgBox "Die Daten aus " & intSh - 2 & " Tabellenblättern wurden gelistet.", 64
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
End Sub
Public Function fncLastRow(ByVal intSh As Integer, intLastS As Integer) As Long
Dim intS As Integer
With Worksheets(intSh)
For intS = 1 To intLastS
If .Cells(Rows.Count, intS).End(xlUp).Row > fncLastRow Then
fncLastRow = .Cells(Rows.Count, intS).End(xlUp).Row
End If
Next
End With
End Function
so weit alles ok
Was ich nun noch gerne -wenn möglich- als Ergänzung hätte;
Es wird aus allen Tabellenblättern kopiert, außer 2 Blättern "Inhalt" und "Vorlage".
Des weiteren steht in allen Blättern in "A4" ein Titel. Dieser Titel soll entsprechend angefügt werden (wäre in Spalte "K" der Tabelle "Zusammenfassung").
Kann mir bitte jemand diese zwei Ergänzungen schreiben?
Eine vereinfachte Mappe zur Verdeutlichung
https://www.herber.de/bbs/user/129107.xlsb
Mit freundlichen Gruß
Fred Neumann