Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
732to736
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
732to736
732to736
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Daten in neue Arbeitsmappe

Daten in neue Arbeitsmappe
Boehme
Hallo ihr VBA Freaks, ich habe einen Code, der mir sondierte Daten in eine neue angehängte Tabelle schreibt. Nun möchte ich aber, das die Daten in eine externe Tabelle geschrieben werden, einfach in eine ganz neue Tabelle. Ihr wisst das doch sicher.
Danke, Sven
Das ist mein derzeitiger Code:

Sub superCopy()
Dim msg
Dim wksPers As Worksheet
Dim wksZiel As Worksheet
Dim intAnz As Integer
Dim lngZiel As Long
Dim varFind As Variant
lngZiel = 2
Set wksPers = Worksheets(1)
intAnz = Worksheets.Count
If intAnz < 2 Then Exit Sub
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
Set wksZiel = Worksheets(Worksheets.Count)
For intWks = 2 To intAnz
varKrit = Worksheets(intWks).Name
If varKrit = "" Then
GoTo Weiter
Else
With wksPers.Range("B:B")
Set varFind = .Find(What:=varKrit, After:=Range("B2"), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
MatchCase:=True)
If Not varFind Is Nothing Then
Rows(1).Font.FontStyle = "Fett"
wksZiel.Name = "Auswertung"
wksZiel.Range("a1") = "Pers-Nr."
wksZiel.Range("b1") = "Name, Vorname"
wksZiel.Range("c1") = "Abteilung"
wksZiel.Range("d1") = "Jahr"
wksZiel.Range("e1") = "K /Tage"
wksZiel.Range("f1") = "Ko /Tage"
wksZiel.Range("g1") = "Urlaub"
wksZiel.Range("h1") = "Üb dieses Jahr"
wksZiel.Range("i1") = "Ab dieses Jahr"
wksZiel.Range("j1") = "Üb-Ab gesamte Jahre"
If Year(Date) = 2006 Then
Worksheets(intWks).Range("b2").Copy 'Pers-Nr
wksZiel.Cells(lngZiel, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("H2").Copy 'Name
wksZiel.Cells(lngZiel, 2).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("S2").Copy 'Abteilung
wksZiel.Cells(lngZiel, 3).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("B62").Copy 'Jahr
wksZiel.Cells(lngZiel, 4).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("at112").Copy 'krank/Tage
wksZiel.Cells(lngZiel, 5).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("au112").Copy 'krank ohne/Tage
wksZiel.Cells(lngZiel, 6).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("ba113").Copy 'Urlaub
wksZiel.Cells(lngZiel, 7).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("av112").Copy 'Überstunden
wksZiel.Cells(lngZiel, 8).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("aw112").Copy 'Abbau Überstunden
wksZiel.Cells(lngZiel, 9).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("bg112").Copy 'Differenz Üb-Ab
wksZiel.Cells(lngZiel, 10).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
lngZiel = lngZiel + 1
End If
If Year(Date) = 2007 Then
Worksheets(intWks).Range("b2").Copy 'Pers-Nr
wksZiel.Cells(lngZiel, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("H2").Copy 'Name
wksZiel.Cells(lngZiel, 2).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("S2").Copy 'Abteilung
wksZiel.Cells(lngZiel, 3).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("B62").Copy 'Jahr
wksZiel.Cells(lngZiel, 4).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("at168").Copy 'krank/Tage
wksZiel.Cells(lngZiel, 5).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("au168").Copy 'krank ohne/Tage
wksZiel.Cells(lngZiel, 6).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("ba169").Copy 'Urlaub
wksZiel.Cells(lngZiel, 7).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("av168").Copy 'Überstunden
wksZiel.Cells(lngZiel, 8).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("aw168").Copy 'Abbau Überstunden
wksZiel.Cells(lngZiel, 9).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("bg168").Copy 'Differenz Üb-Ab
wksZiel.Cells(lngZiel, 10).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
lngZiel = lngZiel + 1
End If
Else
GoTo Weiter
End If
End With
End If
Weiter:
Next
End Sub

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Daten in neue Arbeitsmappe
17.02.2006 11:15:26
yogi
Tach Sven
kopieren geht auch so:
Worksheets(intWks).Range("b2").Copy Destination:=wksZiel.Cells(lngZiel, 1)
wenn Du nun wksZiel als Tabele in einer neuen Arbeitsmappe definierst, ist das Problem gelöst:
Workbooks.Add
ActiveWorkbook.Name = "Neue Datei"
Set wksZiel = ActiveWorkbook.Sheets(1)
Gruss
yogi
AW: Daten in neue Arbeitsmappe
17.02.2006 15:24:44
Sven
Hallo Yogi,
danke für die schnelle Antwort.
vielleicht kannst du mir noch eine Frage beantworten:
Wenn die kumulierten Daten in dieser alten Tabelle angehängt werden in ein neues Blatt mit Namen "Auswertung", dann soll bei einer neuen Abfrage der alte Inhalt überschrieben werden. Bisher kam immer ein Fehlermeldung, da die Datei bereits vorhanden war.
was muss ich noch machen ?
Anzeige
AW: Daten in neue Arbeitsmappe
20.02.2006 08:49:34
yogi
Moin Sven
die Frage verstehe ich leider nicht ganz. Versuchts du, ein neues Tabellenblatt mit dem gleichen Namen einzfügen oder die Arbeitsmappe unter dem Namen einer bereits existierenden abzuspeichern?
Gruss
yogi
AW: Daten in neue Arbeitsmappe
20.02.2006 09:04:37
Sven
Hallo Yogi,
ich möchte den bereits bekannten Code erweitern indem geprüft wird, ob die Tabelle "Auswertung" bereits vorhanden ist. Wenn "ja", soll diese überschrieben werden, wenn "nein", soll sie neu angelegt werden. Bisher wird die Tabelle einfach angelegt. Wenn sie aber nicht gelöscht worden ist und noch einmal generiert wird, kommt es zu einer Fehlermeldung. Das möchte ich verhindern. Hier noch mal der Code:

Sub superCopy()
Dim msg
Dim wksPers As Worksheet
Dim wksZiel As Worksheet
Dim intAnz As Integer
Dim lngZiel As Long
Dim varFind As Variant
lngZiel = 2
Set wksPers = Worksheets(1)
intAnz = Worksheets.Count
If intAnz < 2 Then Exit Sub
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
Set wksZiel = Worksheets(Worksheets.Count)
For intWks = 2 To intAnz
varKrit = Worksheets(intWks).Name
If varKrit = "" Then
GoTo Weiter
Else
With wksPers.Range("B:B")
Set varFind = .Find(What:=varKrit, After:=Range("B2"), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
MatchCase:=True)
If Not varFind Is Nothing Then
Rows(1).Font.FontStyle = "Fett"
wksZiel.Name = "Auswertung"
wksZiel.Range("a1") = "Pers-Nr."
wksZiel.Range("b1") = "Name, Vorname"
wksZiel.Range("c1") = "Abteilung"
wksZiel.Range("d1") = "Jahr"
wksZiel.Range("e1") = "K /Tage"
wksZiel.Range("f1") = "Ko /Tage"
wksZiel.Range("g1") = "Urlaub"
wksZiel.Range("h1") = "Üb dieses Jahr"
wksZiel.Range("i1") = "Ab dieses Jahr"
wksZiel.Range("j1") = "Üb-Ab gesamte Jahre"
If Year(Date) = 2006 Then
Worksheets(intWks).Range("b2").Copy 'Pers-Nr
wksZiel.Cells(lngZiel, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("H2").Copy 'Name
wksZiel.Cells(lngZiel, 2).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("S2").Copy 'Abteilung
wksZiel.Cells(lngZiel, 3).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("B62").Copy 'Jahr
wksZiel.Cells(lngZiel, 4).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("at112").Copy 'krank/Tage
wksZiel.Cells(lngZiel, 5).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("au112").Copy 'krank ohne/Tage
wksZiel.Cells(lngZiel, 6).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("ba113").Copy 'Urlaub
wksZiel.Cells(lngZiel, 7).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("av112").Copy 'Überstunden
wksZiel.Cells(lngZiel, 8).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("aw112").Copy 'Abbau Überstunden
wksZiel.Cells(lngZiel, 9).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("bg112").Copy 'Differenz Üb-Ab
wksZiel.Cells(lngZiel, 10).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
lngZiel = lngZiel + 1
End If
If Year(Date) = 2007 Then
Worksheets(intWks).Range("b2").Copy 'Pers-Nr
wksZiel.Cells(lngZiel, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("H2").Copy 'Name
wksZiel.Cells(lngZiel, 2).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("S2").Copy 'Abteilung
wksZiel.Cells(lngZiel, 3).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("B62").Copy 'Jahr
wksZiel.Cells(lngZiel, 4).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("at168").Copy 'krank/Tage
wksZiel.Cells(lngZiel, 5).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("au168").Copy 'krank ohne/Tage
wksZiel.Cells(lngZiel, 6).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("ba169").Copy 'Urlaub
wksZiel.Cells(lngZiel, 7).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("av168").Copy 'Überstunden
wksZiel.Cells(lngZiel, 8).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("aw168").Copy 'Abbau Überstunden
wksZiel.Cells(lngZiel, 9).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Worksheets(intWks).Range("bg168").Copy 'Differenz Üb-Ab
wksZiel.Cells(lngZiel, 10).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
lngZiel = lngZiel + 1
End If
Else
GoTo Weiter
End If
End With
End If
Weiter:
Next
End Sub

Anzeige
AW: Daten in neue Arbeitsmappe
20.02.2006 14:19:23
yogi
Tach Sven
mit
' prüfen ob Datei existiert
test=dir ("C:\ein_odner\datei_muss_weg.xls")
If test"" Then
' Achtung: Datei darf nicht geöffnet sein!
' Datei löschen
Kill "C:\ein_odner\datei_muss_weg.xls"
End If
kannst du eine bestehende Datei löschen.
Gruss
yogi
AW: Daten in neue Arbeitsmappe
20.02.2006 14:40:28
Sven
Hallo Yogi, da haben wir uns missverstanden. Ich möchte keine Datei löschen, sondern lediglich das Tabellenblatt "Auswertung" (sofern es schon existiert) überschreiben.
AW: Daten in neue Arbeitsmappe
20.02.2006 15:24:56
yogi
Tach Sven
zum Check ob das Tabellenblatt existiert:
' Holzhammermethode
On error resume next
Worksheets("Auswertung").Select
If Err0 Then
' Blatt existiert nicht, neues hinzufügen
Sheets.Add
Sheet.Name="Auswertung"
Err.Clear
End If
On Error Goto 0
Gruss
yogi
Anzeige
AW: Daten in neue Arbeitsmappe
21.02.2006 10:22:58
Sven
sorry Yogi, aber das hilft mir alles nicht,
ich habe keinen Plan von VBA.
vielleichtt benutzt du den Code, den ich bereits zu Verfügung gestellt habe, um ihn zu ändern, sodass das Tabellenblatt "Auswertung" immer angelegt wird, egal ob es schon da ist oder nicht, sprich, wenn es da ist, das es gelöscht bzw. überschrieben wird, ansonsten angelegt wird. Sonst komme ich hier nicht weiter. Danke

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige