Per VBA eine übergr. Datei Zelle für Zelle kopiere

Hi zusammen,
ich habe eine Datei die sich mit der Zeit aufgebläht hat und von Mal zu Mal größer wird. Daher war meine Idee diese Datei Zelle für Zelle nur den reinen Text per Makro zu kopieren. Danach noch folgende Punkte:
- Register Farbe
- Spaltenbreite
- spaltenhöhe
Das habe ich mir bis jetzt zusammenkopiert ... funktioniert aber nicht wirklich zufriedenstellend bzw. das mit der Spaltenbreite und Höhe der Reihen gar nicht. Hat jemand so was? Bzw. wie hoch seht Ihr die Chance das die größe der Datei sich verbessert? Toll wär wenn jemand schon mal einen ähnliche Idee hatte.
LG
Andreas

Sub im_Hintergrund_bestehende_mappe_oeffnen()
'falls ein Fehler auftritt gehe zur Fehlerbehandlung
On Error GoTo errhandler
Dim objAppExcel As Object
Dim objWb As Object
Dim objSH As Object
Dim AktuelleMappe As Workbook
Dim rngArr, rngSource, rngTarget
Dim I As Integer
Dim WS_Countdest, WS_Countsource As Integer
Dim iCounter As Variant
Set AktuelleMappe = ActiveWorkbook
Set objAppExcel = CreateObject("Excel.Application")
Set objWb = objAppExcel.Workbooks.Open("C:\Users\grisu20\Desktop\Einteilung\Einteilung v. 1.6.  _
_
xlsm")
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Countsource = objWb.Worksheets.Count
WS_Countdest = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Countsource
Set objSH = objWb.Sheets(I)
Sheets.Add
ActiveSheet.Name = objWb.Sheets(I).Name
With objSH
rngArr = .Range(.Cells(1, 1), varLast(3, objWb.Sheets(I)))
Set rngSource = .Range(.Cells(1, 1), varLast(3, objWb.Sheets(I)))
End With
AktuelleMappe.Sheets(I).Range(Cells(1, 1), varLast(3, objWb.Sheets(I))).Value = rngArr
Set rngTarget = AktuelleMappe.Sheets(I).Range(Cells(1, 1), varLast(3, objWb.Sheets(I)))
For iCounter = 1 To AktuelleMappe.rngSource.Rows.Count
rngTarget.Rows(iCounter).RowHeight = _
rngSource.Rows(iCounter).RowHeight
Next iCounter
For iCounter = 1 To rngSource.Columns.Count
rngTarget.Columns(iCounter).ColumnWidth = _
rngSource.Columns(iCounter).ColumnWidth
Next iCounter
Next
objWb.Close savechanges:=False
objAppExcel.Quit
Set objSH = Nothing
Set objWb = Nothing
Set objAppExcel = Nothing
Exit Sub
errhandler:
MsgBox "Fehlernr:" & Err.Number & " " & Err.Description
objWb.Close savechanges:=False
objAppExcel.Quit
Set objSH = Nothing
Set objWb = Nothing
Set objAppExcel = Nothing
End Sub