XL2k/03: Kopieren von Blättern per VBA - Kopiert nur erste 255 Zeichen in den Zellen

04/08/2009 - 15:08 von Steffen Trog | Report spam
Hallo,

mit folgender Routine kopiere ich alle Tabellenblàtter in eine andere Datei:

For i = 1 To ActiveWorkbook.Sheets.Count
Windows(quelle).Activate
Sheets(i).Activate
Sheets(i).Copy After:=Workbooks(ziel).Sheets(i)
Next i

Klappt soweit. Nur ist mir aufgefallen, dass, wenn in den Zellen mehr als
255 Zeichen Text drinsteht,
im Ziel nur die ersten 255 Zeichen ankommen. Der Rest fehlt.

Hat mir jemand eine Idee oder ein QorkAround dazu ?

Danke und viele Gruesse

St. Trog
 

Lesen sie die antworten

#1 Andreas Killer
04/08/2009 - 18:18 | Warnen spam
Steffen Trog schrieb:

mit folgender Routine kopiere ich alle Tabellenblàtter in eine andere Datei:


...
Klappt soweit. Nur ist mir aufgefallen, dass, wenn in den Zellen mehr als
255 Zeichen Text drinsteht, im Ziel nur die ersten 255 Zeichen ankommen. Der Rest fehlt.


Es gibt noch mehr Hindernisse beim Kopieren, die einzigste Lösung die
mir hierfür eingefallen ist, ist im Zielblatt nach Werten/Formeln zu
suchen die lànger 255 Zeichen sind und diese einzeln direkt nachzutragen.

Probier mal angehàngte Routine(n), wàre nett wenn Du Beschied gibst ob
sie für Deine Mappe(n) funktioniert.

Andreas.

Sub CopySheets(Optional ByVal OldBook As Workbook = Nothing, _
Optional ByVal NewBook As Workbook = Nothing, _
Optional ByVal SheetName As String = "*", _
Optional ByVal OverWriteSheets As Boolean = True)
'Kopiert die gewünschten Sheets von Mappe OldBook nach Mappe _
NewBook
Dim S As Variant, C As Range, B As Shape, I As Long
Dim OldName As String, AfterSheet As Integer, TempSheet As _
Worksheet

If OldBook Is Nothing Then Set OldBook = ActiveWorkbook
OldName = OldBook.Name

If NewBook Is Nothing Then Set NewBook = Workbooks.Add
If NewBook Is OldBook Then Exit Sub

Application.ScreenUpdating = False
Set TempSheet = Nothing
For Each S In OldBook.Sheets
If S.Name Like SheetName Then
'Tabellen nacheinander kopieren
AfterSheet = NewBook.Sheets.Count
If OverWriteSheets Then
If SheetExists(S.Name, NewBook) Then
If NewBook.Sheets.Count = 1 Then Set TempSheet = _
NewBook.Sheets.Add
AfterSheet = NewBook.Sheets(S.Name).Index - 1
DeleteSheet S.Name, NewBook
End If
End If
If AfterSheet = 0 Then
S.Copy Before:=NewBook.Sheets(AfterSheet + 1)
Else
S.Copy After:=NewBook.Sheets(AfterSheet)
End If

Select Case TypeName(S)
Case "Worksheet"
For Each C In S.UsedRange
With NewBook.Sheets(S.Name).Cells(C.Row, C.Column)
If C.HasFormula Then
If Len(C.Formula) > 255 Then .Formula = C.Formula
Else
If Len(C.Value) > 255 Then .Value = C.Value
End If
End With
Next
Case "Chart"
'Okay
End Select
End If
Next
If Not TempSheet Is Nothing Then DeleteSheet TempSheet.Name, _
NewBook

For Each S In NewBook.Sheets
Select Case TypeName(S)
Case "Worksheet"
'Formeln korrigieren
For Each C In S.UsedRange
If C.HasFormula Then C.Formula = Replace(C.Formula, "[" _
& OldName & "]", "")
Next
'Button's korrigieren
For Each B In S.Shapes
If Len(B.OnAction) > 0 Then B.OnAction = NewBook.Name & _
Mid(B.OnAction, InStr(B.OnAction, "!"))
Next
Case "Chart"
For I = 1 To S.SeriesCollection.Count
With S.SeriesCollection(I)
.Formula = Replace(.Formula, "[" & OldName & "]", "")
End With
Next
End Select
Next

Sheets(OldBook.ActiveSheet.Name).Select
Application.ScreenUpdating = True
End Sub

Function SheetExists(ByVal SheetName As String, _
Optional Wb As Workbook = Nothing) As Boolean
'Prüft ob das Tabellenblatt SheetName existiert
Dim S As Worksheet
If Wb Is Nothing Then Set Wb = ActiveWorkbook
SheetExists = True
SheetName = Mid(SheetName, 1, 31)
For Each S In Wb.Sheets
If S.Name = SheetName Then Exit Function
Next
SheetExists = False
End Function

Sub DeleteSheet(Optional ByVal SheetName As String = "", _
Optional Wb As Workbook = Nothing)
'Löscht das angegebene Tabellenblatt
Dim Alerts As Boolean
If Wb Is Nothing Then Set Wb = ActiveWorkbook
If SheetName = "" Then SheetName = Wb.ActiveSheet.Name
'Es muss immer mind. 1 Tabellenblatt vorhanden sein
If Wb.Sheets.Count = 1 Then Wb.Sheets.Add
'Fehlermeldungen ausschalten
Alerts = Application.DisplayAlerts
Application.DisplayAlerts = False
'Fehlerbehandlung aus, falls SheetName nicht existiert
On Error Resume Next
Wb.Sheets(SheetName).Delete
On Error GoTo 0
Application.DisplayAlerts = Alerts
End Sub

Ähnliche fragen