Kopieren funktioniert nicht

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