Tabelle in bestehende Datei enfügen

Hallo Profis!
ich habe folgende Problemstellung:
ich habe eine Excel mit vielen Tabellen, die im Prinzip alle gleich aufgebaut sind. Am Ende dieser Datei A soll eine Tabelle Datenauswertung erzeugt werden, in der alle Daten bestimmter Spalten der weiteren Tabellen untereinander aufgelistet sind. Daraus möchte ich meine Datenauswertung machen.
Den entsprechenden Code dafür habe ich bereits.
Meine Frage ist nun: ich möchte diese Tabelle Datenauswertung in einer Datei B speichern. Das soll aber eine bestehende Datei sein. Die Tabelle Datenauswertung soll in B ein neues Tabellenblatt werden. wie geht das? bis dato kann ich nur aus der Tabelle eine eigenständige Datei machen.
Hier ist mein bisheriger Code hinterlegt:
https://www.herber.de/bbs/user/112321.xlsm
Danke, für Eure Hilfe!
Annika

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub tabelle_in_andere_datei() Dim ws As Worksheet Set ws = ThisWorkbooks.Sheets("Dein Sheet") ws.Activate ws.Select Selection.Copy Destination:=Workbook("C:\..\..\Datei.xls").Sheets("Sheet wo es hin soll"). _ Range("A1") Set ws = Nothing End Sub

Option Explicit Sub blatt_abspeichern() Dim sh As Shape Dim vDate As String Application.ScreenUpdating = False 'Datum im Format: "JahrMonatTag" --> "20170127" vDate = Format(Date, "DD.MM.YY") Application.DisplayAlerts = False Range("A2").Select Sheets("Datenauswertung").Select Sheets("Datenauswertung").Copy Cells.Select Selection.Copy 'Füge die Daten ein Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("A2").Select Application.CutCopyMode = False 'Speichern in anderer Datei Dim ws As Worksheet Set ws = ThisWorkbooks.Sheets("Datenauswertung") ws.Activate ws.Select Selection.Copy Destination:=Workbook("X:\YYY.xls").Sheets("Datenauswertung"). _ Range("A1") Set ws = Nothing 'Lösche die Buttons raus For Each sh In ActiveSheet.Shapes If TypeName(sh.OLEFormat.Object) = "Button" Then sh.Delete Next ActiveWorkbook.Save ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Option Explicit Sub blatt_in_datei() Dim wbToPaste As Workbook Dim wsToCopy, wsToPaste As Worksheet Dim counter As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False 'Speichern in anderer Datei Set wsToCopy = ThisWorkbook.Sheets("Datenauswertung") '//Wir öffnen erst die Datei wo die Tabelle hinsoll Workbooks.Open "C:\Users\ich\Desktop\Mappe1.xlsx" '

Option Explicit Sub blatt_in_datei() Dim wbToPaste As Workbook Dim wsToCopy, wsToPaste As Worksheet Dim counter As Integer Dim sh As Shape Application.ScreenUpdating = False Application.DisplayAlerts = False 'Speichern in anderer Datei Set wsToCopy = ThisWorkbook.Sheets("Datenauswertung") '//Wir öffnen erst die Datei wo die Tabelle hinsoll Workbooks.Open "XXXxlsm" ''Lösche die Buttons raus For Each sh In ActiveSheet.Shapes If TypeName(sh.OLEFormat.Object) = "Button" Then sh.Delete Next ActiveWorkbook.Save ActiveWorkbook.Close Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Option Explicit Sub daten_in_Blatt() Dim ws As Worksheet Dim ws2 As Worksheet Dim lzeile As Long Dim lzeile2 As Long Dim rng As Range Dim rng2 As Range Dim wsAnzahl As Integer Dim i, j Dim x, k Dim tabuTabellen Dim y Dim bool As Boolean Dim count As Integer '//Alte Daten entfernen Call daten_loeschen '//Anzahl der vorhandenen Sheets wsAnzahl = ThisWorkbook.Sheets.count i = 1: j = 0: k = 1 x = Array(3, 11, 12, 13, 14, 24, 26, 27, 33, 37, 38, 40, 41, 42, 46) tabuTabellen = Array("Datenauswertung", "Inhalt", "FAQ") Application.ScreenUpdating = False Do Set ws = ThisWorkbook.Sheets("Datenauswertung") bool = False For y = 0 To UBound(tabuTabellen) If ThisWorkbook.Sheets(i).Name = tabuTabellen(y) Then count = count + 1 If count > 0 Then bool = True count = 0 End If End If Next y If bool = True Then GoTo nextBlatt Set ws2 = ThisWorkbook.Sheets(i) '//Setzen des zu kopierenden Bereichs '//anschließend Bereich kopieren With ws2 lzeile2 = .Cells(.Rows.count, x(j)).End(xlUp).Row If lzeile2 = 9 Then lzeile2 = lzeile2 + 1 Set rng2 = .Range(.Cells(10, x(j)), .Cells(lzeile2, x(j))) If lzeile2 (wsAnzahl) Then j = j + 1 i = 1 End If Loop Until j > UBound(x) Application.ScreenUpdating = True End Sub

Guten Morgen,
probiere es mal mit dem Code:


Option Explicit
Sub daten_in_Blatt()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lzeile As Long
Dim lzeile2 As Long
Dim rng As Range
Dim rng2 As Range
Dim wsAnzahl As Integer
Dim i, j, k, y
Dim x
Dim tabuTabellen
Dim bool As Boolean
Dim count As Integer
'//Alte Daten entfernen
Call daten_loeschen
'//Anzahl der vorhandenen Sheets
wsAnzahl = ThisWorkbook.Sheets.count
i = 1: j = 0: k = 1
x = Array(3, 11, 12, 13, 14, 24, 26, 27, 33, 37, 38, 40, 41, 42, 46)
tabuTabellen = Array("Datenauswertung", "Inhalt", "FAQ", "neueDatei", _
"Inhaltsverzeichnis")
Application.ScreenUpdating = False
Do
Set ws = ThisWorkbook.Sheets("neueDatei")
bool = False
For y = 0 To UBound(tabuTabellen)
If ThisWorkbook.Sheets(i).Name = tabuTabellen(y) Then
count = count + 1
If count > 0 Then
bool = True
count = 0
End If
End If
Next y
If bool = True Then GoTo nextBlatt
Set ws2 = ThisWorkbook.Sheets(i)
'//Setzen des zu kopierenden Bereichs
'//anschließend Bereich kopieren
With ws2
lzeile2 = .Cells(.Rows.count, x(j)).End(xlUp).Row
If lzeile2 = 9 Then lzeile2 = lzeile2 + 1
Set rng2 = .Range(.Cells(10, x(j)), .Cells(lzeile2, x(j)))
If lzeile2  (wsAnzahl) Then
j = j + 1
i = 1
k = k + 1
End If
Loop Until j > UBound(x)
Application.ScreenUpdating = True
End Sub

Bei mir macht er alles richtig, ich hoffe bei dir auch.
Ich habe es jetzt so gemacht dass in der ersten Zeile auf "neueDatei" immer
drinnen steht nach was er gesucht hat.

Option Explicit Sub spalten_definiert() Dim ws As Worksheet Dim userInput As String Set ws = ThisWorkbook.Sheets("Datenauswertung") With ws userInput = Application.InputBox("Geben Sie die Spalte an, wo die neue Spalte eingefügt _ werden soll", "Spalte_xy") .Range(userInput & 1).EntireColumn.Insert End With End Sub

Option Explicit Sub blatt_abspeichern_2() Dim wbToPaste As Workbook Dim wsToCopy, wsToPaste As Worksheet Dim ws As Worksheet Dim counter As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False 'Speichern in anderer Datei Set wsToCopy = ThisWorkbook.Sheets("Datenauswertung") '//Wir öffnen erst die Datei wo die Tabelle hinsoll Workbooks.Open "C:\Users\max.bader\Desktop\Mappe1.xlsm" '

Beliebteste Forumthreads (12 Monate)

Tabelle in bestehende Datei enfügen

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabelle in bestehende Datei enfügen

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread