PDA

Vollständige Version anzeigen : Code von Tabelle auf Mappe anpassen


Torsang
19.07.2014, 11:46
Hallo

Ich habe folgenden Code:
Sub Aktuelles_Blatt_umwandeln()
Dim Neuer_Dateiname
Dim i As Integer
Application.ScreenUpdating = False
ActiveSheet.Unprotect
ActiveSheet.Copy
ActiveSheet.DrawingObjects.Delete
Cells.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Damit kopiere ich ein Tabellenblatt OHNE Macros, Formeln und Buttons.
Das funktioniert einwandfrei.

Wie muß der Code abgeändert werden, damit eine ganze Mappe
umgewandelt wird.

Ich habe zwar noch diesen Code:
Sub Mappe_umwandeln()
Dim wbNeu As Workbook
Dim wbAlt As Workbook
Dim sh As Worksheet
Dim i As Long
Dim Anz As Long
Dim DatName As String
Application.ScreenUpdating = False
Call X_entfernen
Set wbAlt = ActiveWorkbook
Anz = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wbAlt.Sheets.Count
Set wbNeu = Workbooks.Add
Application.SheetsInNewWorkbook = Anz
'--- Daten kopieren nur Werte
For i = 1 To wbAlt.Worksheets.Count
wbAlt.Sheets(i).Cells.Copy
wbNeu.Sheets(i).Cells(1, 1).PasteSpecial xlPasteValues
wbNeu.Sheets(i).Cells(1, 1).PasteSpecial xlPasteFormats
wbNeu.Sheets(i).Name = wbAlt.Sheets(i).Name
Next
Application.ScreenUpdating = True
End Sub
aber dabei werden versteckte Zeilen und/oder Spalten sichtbar gemacht,
was nicht sein soll und bei dem ersten Code auch nicht passiert.

Kann jemand helfen ?

Nette Grüße
Torsten

Hasso
19.07.2014, 12:36
Hallo Torsten,

warum kombinierst du nicht die beiden Codes?Sub Mappe_umwandeln()
Dim wbNeu As Workbook
Dim wbAlt As Workbook
Dim sh As Worksheet
Dim i As Long
Dim Anz As Long
Dim DatName As String
Application.ScreenUpdating = False
Call X_entfernen
Set wbAlt = ActiveWorkbook
Anz = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wbAlt.Sheets.Count
Set wbNeu = Workbooks.Add
Application.SheetsInNewWorkbook = Anz
'--- Daten kopieren nur Werte
For i = 1 To wbAlt.Worksheets.Count
With wbAlt
.Sheets(i).Unprotect
.Sheets(i).Cells.Copy
.DrawingObjects.Delete
.Cells.Copy
End With
wbNeu.Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=Range("A1").Select
wbNeu.Sheets(i).Name = wbAlt.Sheets(i).Name
Next
Application.ScreenUpdating = True
End Sub

Torsang
19.07.2014, 14:40
Vielen Dank für die Antwort !

Leider bekomme ich bei
wbNeu.Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=Range("A1").Select
die Fehlermeldung: "Objekt Unterstützt diese Eigenschaft oder Methode nicht"

Wat nu ?

Nette Grüße
Torsten

Hajo_Zi
19.07.2014, 14:43
was möchtest Du mit diesem Ausdruck aus Deinem Code erreichen. Da wird eigentlich ein Wert True oder False erwartet, kein select.
SkipBlanks:= _
Range("A1").Select


<a href="http://Hajo-Excel.de/index.htm" target="_blank" title="Hajo's Excelseiten">Gruß Hajo</a>

R J
19.07.2014, 14:50
Hi Torsten,

versuchs mal so (nur die sichtbaren Zellen kopieren):
Option Explicit

Sub Mappe_umwandeln()
Dim wbNeu As Workbook
Dim wbAlt As Workbook
Dim sh As Worksheet
Dim i As Long
Dim Anz As Long
Dim DatName As String
Dim rng As String
Dim r As Double

Application.ScreenUpdating = False
'Call X_entfernen
Set wbAlt = ActiveWorkbook
r = wbAlt.Sheets(1).Rows.Count 'Ermittlung erforderlich wegen unterschiedlicher Zeilenanzahl der Excelversionen...
'Anz = Application.SheetsInNewWorkbook
'Application.SheetsInNewWorkbook = wbAlt.Sheets.Count
Set wbNeu = Workbooks.Add
'Application.SheetsInNewWorkbook = Anz
'--- Daten kopieren nur Werte und Formate (!) der sichtbaren Zeilen und Spalten
For i = 1 To wbAlt.Worksheets.Count
wbAlt.Sheets(i).DrawingObjects.Delete
rng = wbAlt.Sheets(i).Cells.SpecialCells(xlVisible).Address(0, 0)
rng = Replace(rng, r, wbAlt.Sheets(i).Cells.SpecialCells(xlLastCell).Row)
wbAlt.Sheets(i).Range(rng).Copy
'Wenn nur Werte (wie ursprünglich angegeben) kopiert werden sollen, dann:
' xlPasteValuesAndNumberFormats ersetzen durch xlPasteValues
wbNeu.Sheets(i).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
wbNeu.Sheets(i).Name = wbAlt.Sheets(i).Name
Next

Set wbNeu = Nothing
Set wbAlt = Nothing
Application.ScreenUpdating = True
End Sub

Torsang
19.07.2014, 15:10
Danke für die Antwort !

Ich habe den Code schon so angepasst:
Sub Mappe_umwandeln2()
Dim wbNeu As Workbook
Dim wbAlt As Workbook
Dim sh As Worksheet
Dim i As Long
Dim Anz As Long
Dim DatName As String
Application.ScreenUpdating = False
Call X_entfernen
Set wbAlt = ActiveWorkbook
Anz = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wbAlt.Sheets.Count
Set wbNeu = Workbooks.Add
Application.SheetsInNewWorkbook = Anz
'--- Daten kopieren nur Werte
For i = 1 To wbAlt.Worksheets.Count
With wbAlt
.Sheets(i).Unprotect
.Sheets(i).Cells.Copy
.Sheets(i).Cells.Copy
End With
wbNeu.Sheets(i).Range("A1").PasteSpecial Paste:=xlValues
wbNeu.Sheets(i).Range("A1").PasteSpecial xlPasteFormats
wbNeu.Sheets(i).DrawingObjects.Delete
wbNeu.Sheets(i).Name = wbAlt.Sheets(i).Name
Next
Application.ScreenUpdating = True
End Sub

Das funktioniert auch - leider werden versteckte Zeilen mit eingeblendet und das Gitter ist sichtbar.

Nette Grüße
Torsten

Torsang
19.07.2014, 16:47
Habe es so hinbekommen:
Sub Mappe_umwandeln()
Dim wbNeu As Workbook
Dim wbAlt As Workbook
Dim sh As Worksheet
Dim i As Long
Dim Anz As Long
Dim DatName As String
Application.ScreenUpdating = False
'Call X_entfernen
Set wbAlt = ActiveWorkbook
Anz = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wbAlt.Sheets.Count
Set wbNeu = Workbooks.Add
Application.SheetsInNewWorkbook = Anz
'--- Daten kopieren nur Werte
For i = 1 To wbAlt.Worksheets.Count
wbAlt.Sheets(i).Cells.Copy
wbNeu.Sheets(i).Cells(1, 1).PasteSpecial xlPasteValues
wbNeu.Sheets(i).Cells(1, 1).PasteSpecial xlPasteFormats
wbNeu.Sheets(i).Rows("50:78").Hidden = True
wbNeu.Sheets(i).Rows("1:7").Hidden = True
wbNeu.Sheets(i).DisplayHeadings = False
wbNeu.Sheets(i).DisplayGridlines = False
wbNeu.Sheets(i).Name = wbAlt.Sheets(i).Name
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
Allerdings erkennt er nicht an, dass ich die Überschriften
und die Gitternetzlinien nicht haben möchte.

Wie kann ich das ändern ?

Nette Grüße
Torsten

Torsang
20.07.2014, 08:49
So - funktioniert soweit alles.
Nur es muß bei einem Tabellenblatt ein Bild mit kopiert werden.
Wie muß ich das dann anpassen ?
Sub Mappe_umwandeln()
Dim wbNeu As Workbook
Dim wbAlt As Workbook
Dim sh As Worksheet
Dim i As Long
Dim Anz As Long
Dim DatName As String
Application.ScreenUpdating = False
Set wbAlt = ActiveWorkbook
Anz = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = wbAlt.Sheets.Count
Set wbNeu = Workbooks.Add
Application.SheetsInNewWorkbook = Anz
'--- Daten kopieren nur Werte
For i = 1 To wbAlt.Worksheets.Count
wbAlt.Sheets(i).Cells.Copy
wbNeu.Sheets(i).Cells(1, 1).PasteSpecial xlPasteValues
wbNeu.Sheets(i).Cells(1, 1).PasteSpecial xlPasteFormats
wbNeu.Sheets(i).Rows("50:78").Hidden = True
wbNeu.Sheets(i).Rows("1:7").Hidden = True
wbNeu.Sheets(i).Name = wbAlt.Sheets(i).Name
Next
For i = 1 To Sheets.Count
Sheets(i).Activate
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
Range("B10").Select
End With
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
Call X_entfernen
End Sub


Nette Grüße
Torsten

Torsang
20.07.2014, 14:32
Habe es selber hinbekommen.

Nette Grüße
Torsten