Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
736to740
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
736to740
736to740
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Kopieren funktioniert nicht

Kopieren funktioniert nicht
01.03.2006 17:06:25
petra
Hallo,
hab folgenden Makro, der leider nur zum Teil funktioniert und ich nicht weiß wo der fehler liegt:

Sub WerteSpeichern()
Dim newWB As Workbook
Dim szName$, lShtCnt&, bFound As Boolean, bState As Boolean
'Planübersicht soll kopiert werden
'Namen des neuen Tabellenblatts auslesen
szName = ThisWorkbook.Sheets(1).Cells(3, 1).Value
'Zieldatei öffnen
For x = 1 To Workbooks.Count
If Workbooks(x).Name = "Prognose-Speicher.xls" Then
bFound = True
Exit For
End If
Next x
If Not bFound Then
MsgBox "Prognose-Speicher nicht offen bzw. nicht gefunden! Bitte öffnen/erstellen!"
Exit Sub
Else
Set newWB = Workbooks(x)
End If
'Überprüfen, ob schon eine Tabelle existiert
bState = False
For lShtCnt = 1 To newWB.Sheets.Count
If newWB.Sheets(lShtCnt).Name = szName Then
'Wenn Tabelle existiert, bState auf True setzen
bState = True
Exit For
End If
Next
If bState = True Then
'Sheet bereits vorhanden --> nur Inhalt kopieren
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Range(Cells(1, 1), Cells(130, 16)).Copy
newWB.Sheets(szName).Range(Cells(1, 1), Cells(130, 16)).PasteSpecial Paste:=xlValues
newWB.Sheets(szName).Range(1, 1).Select
'ThisWorkbook.Activate
Application.CutCopyMode = False
ThisWorkbook.Sheets(1).Range(1, 1).Select
Else
'Sheet nicht vorhanden
ThisWorkbook.Sheets(1).Copy After:=newWB.Sheets(newWB.Sheets.Count)
newWB.Sheets(newWB.Sheets.Count).Name = szName
newWB.Sheets(newWB.Sheets.Count).Cells.Copy
newWB.Sheets(newWB.Sheets.Count).Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
newWB.Sheets(newWB.Sheets.Count).Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End Sub

Der Debugger springt bei folgender Zeile an wenn die Zieldatei bereits eine Tabelle mit dem Namen szName hat und die Werte einfügen will
--> newWB.Sheets(szName).Range(Cells(1, 1), Cells(130, 16)).PasteSpecial Paste:=xlValues
Kann mir jemand sagen, was da falsch ist?
danke euch.
lg
petra

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kopieren funktioniert nicht
01.03.2006 18:35:57
Herbert
hallo petra,
probier diese Zeile so:
newWB.Sheets(szName).Cells(1, 1).PasteSpecial Paste:=xlValues
gruß Herbert
AW: Kopieren funktioniert nicht
01.03.2006 19:53:40
petra
funktioniert auch nicht so:
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Range(Cells(1, 1), Cells(130, 16)).Copy
newWB.Sheets(BSTNr).Cells(1, 1).PasteSpecial Paste:=xlValues
newWB.Sheets(BSTNr).Range(1, 1).Select
'ThisWorkbook.Activate
Application.CutCopyMode = False
ThisWorkbook.Sheets(1).Range(1, 1).Select
der debugger kommt wieder an der gleichen stelle mit umgeschriebener zeile
-- &gt newWB.Sheets(BSTNr).Cells(1, 1).PasteSpecial Paste:=xlValues
und nun?
lg
petra
Anzeige
und nun...
02.03.2006 00:00:25
Herbert
...änderst du vielleicht diese Zeile:
Set newWB = Workbooks(x).Name
gruß Herbert
AW: und nun...
02.03.2006 10:20:49
petra
mag er nicht.
"Typen unverträglich" meint er.
noch andere vorschläge?
lg
petra
AW: und nun...
02.03.2006 12:06:40
Herbert
so funktionierts bei mir jetzt...
Option Explicit

Sub WerteSpeichern()
Dim newWB As Workbook, x%
Dim szName$, i&, bFound As Boolean, bState As Boolean
szName = ThisWorkbook.Sheets(1).[a3]
On Error GoTo errEnde
Application.ScreenUpdating = False
For x = 1 To Workbooks.Count
If Workbooks(x).Name = "Prognose-Speicher.xls" Then
bFound = True
Exit For
End If
Next
If Not bFound Then
MsgBox "Prognose-Speicher nicht offen bzw. nicht gefunden! Bitte öffnen/erstellen!"
Exit Sub
Else
Set newWB = Workbooks(x)
End If
bState = False
For i = 1 To newWB.Sheets.Count
If newWB.Sheets(i).Name = szName Then
bState = True
Exit For
End If
Next
With ThisWorkbook
If bState = True Then
.Activate
.Sheets(1).Range(Cells(1, 1), Cells(130, 16)).Copy
With newWB
.Sheets(szName).Cells(1, 1).PasteSpecial Paste:=xlValues
.Activate
.Sheets(szName).Cells(1, 1).Select
End With
Application.CutCopyMode = False
.Activate
.Sheets(1).Cells(1, 1).Select
Else
With newWB
.Sheets(1).Copy After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = szName
.Sheets(.Sheets.Count).Cells.Copy
.Sheets(.Sheets.Count).Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.Sheets(.Sheets.Count).Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
Application.CutCopyMode = False
End If
End With
errEnde:
Application.ScreenUpdating = False
End Sub

gruß Herbert
Anzeige

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige