Objekt in Sheet einfügen

Hallo zusammen,
ich muß mit großen Excel Dateien arbeiten und dort große Bereiche zwischen den Sheets oder von anderen XLS-Dateien kopieren. Das wird schnell zu einem Geduldsspiel und dauert ewig.
Daher ist mir die Idee gekommen per VBA den zu kopierenden Bereich als Objekt zu definieren und dieses Objekt in das Zielsheet "einzufügen".
Die Definition des Objekts ist klar:
Set obj1 = ActiveSheet.Range("A10:C20")
Wie füge ich per VBA das Objekt (bzw. alle Elemente davon) in ein anderes Sheet ein?
(z. B. in Tabelle1 ab Zelle C5)
Nach Möglichkeit sollen Formeln genauso (also "=D20" soll auch danach noch "=D20" unabhängig in welcher Zelle ich Einfüge) erhalten bleiben und Werte 1:1 übernommen werden, optimal aber kein Muß wäre die Übertragung auch der Formatierung)
Vielen Dank für Euere Anregungen
Klaus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Test() Dim obj1 As Range, rngZiel As Range Dim meAr Dim A&, AA& Dim iCalc As Integer Set obj1 = ActiveSheet.Range("A10:C20") meAr = obj1.Resize(, obj1.Columns.Count + 1).FormulaLocal Redim Preserve meAr(1 To Ubound(meAr), 1 To Ubound(meAr, 2) - 1) On Error Resume Next Set rngZiel = Application.InputBox("Wählen Sie das Ziel", "Zelle auswählen", Type:=8) On Error GoTo 0 If Not rngZiel Is Nothing Then With Application iCalc = .Calculation .EnableEvents = False .ScreenUpdating = False .Calculation = xlCalculationManual On Error GoTo ErrorH obj1.Copy rngZiel(1, 1) rngZiel.Resize(Ubound(meAr), Ubound(meAr, 2)).FormulaLocal = meAr ErrorH: If Err.Number <> 0 Then MsgBox Err.Description, _ vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _ "Error: " & Err.Number, Err.HelpFile, Err.HelpContext End If .EnableEvents = True .ScreenUpdating = True .Calculation = iCalc End With End If End Sub

Hallo,
, müsste es so funktionieren.

Sub Test()
Dim obj1 As Range, rngZiel As Range
Dim meAr()
Dim A&, AA&, LRow, LCol
Dim iCalc As Integer
Dim rngFormel As Range
Dim sngTimer As Single

'Quelle 
Set obj1 = ActiveSheet.Range("A10")

'Formeln in einem Array speichern 
meAr = obj1.Resize(, obj1.Columns.Count + 1).FormulaLocal
'richtige größe herstellen 
Redim Preserve meAr(1 To Ubound(meAr), 1 To Ubound(meAr, 2) - 1)

On Error Resume Next 'Fehler umgehen 
    'sind Formeln im Bereich 
    If obj1.Count > 1 Then 'mehr als eine Zelle? 
        Set rngFormel = obj1.SpecialCells(xlCellTypeFormulas)
    Else
        If obj1.HasFormula Then Set rngFormel = obj1
    End If
    
    'Ziel- Zelle wählen 
    Set rngZiel = Application.InputBox("Wählen Sie das Ziel", "Zelle auswählen", Type:=8)
On Error GoTo 0


If Not rngZiel Is Nothing Then 'keine Zelle gewählt 
    With Application
        iCalc = .Calculation
        .EnableEvents = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        
        On Error GoTo ErrorH 'Fehler abfangen 
        obj1.Copy rngZiel(1, 1) 'Bereich kopieren 
         
        If Not rngFormel Is Nothing Then 'sind Formeln vorhanden? 
                
                'Normale Formeln einfügen 
                rngZiel.Resize(Ubound(meAr), Ubound(meAr, 2)).FormulaLocal = meAr
                
                '1. Zeile und Spalte aus Quelle 
                LRow = obj1(1, 1).Row
                LCol = obj1(1, 1).Column

                'alle Formelzellen durchlaufen wegen Matrix- Formeln 
                For Each rngFormel In rngFormel
                    If rngFormel.HasArray Then 'ist dies eine Matrix- Formel? 
                        'Formel als Matrix- Formel einfügen 
                        rngFormel.Offset(rngFormel.Row - LRow, rngFormel.Column - LCol).FormulaArray = _
                                               meAr(rngFormel.Row - LRow + 1, rngFormel.Column - LCol + 1)
                    End If
                Next rngFormel
          
        End If
  
ErrorH:
        If Err.Number <> 0 Then 'Fehler aufgetreten? 
            'Fehlermeldung ausgeben 
            MsgBox Err.Description, _
                   vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
                   "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
        End If

        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = iCalc
        
      End With 'Application 
End If

End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Objekt in Sheet einfügen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread