Tabellenblätter zusammenführen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Tabellenblätter zusammenführen

21.11.2015 06:09:02

Bernd

AW: Tabellenblätter zusammenführen

21.11.2015 06:38:00

DieterG

AW: Bsp.-Mappe

21.11.2015 08:46:13

hary

AW: Bsp.-Mappe

21.11.2015 10:15:19

DieterG

AW: Bsp.-Mappe

21.11.2015 10:45:17

hary

AW: Bsp.-Mappe

21.11.2015 11:19:22

DieterG

AW:Nachgefragt

21.11.2015 11:36:39

hary

AW: AW:Nachgefragt-

21.11.2015 14:31:07

DieterG

AW:Mappe zurueck

21.11.2015 18:00:27

hary

Danke

21.11.2015 18:28:58

DieterG

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

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

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread