ich habe folgenden Code mit dem ich Daten aus einen Excel-Datei in eine andere Excel-Datei importiere. Leider fügt er alle ein, aber ich möchte nur dass er die Werte übernimmt. Ich habe es mit Paste Special probiert, aber bekomme immer die Meldung, das die Range Methode nicht ausgeführt werden kann. Anscheinend mache ich etwas in der Syntax falsch, weiß aber nicht was?
Ich habe den betreffenden Bereich im Code mit ########## markiert.
Kann mir jemand weiterhelfen?
Vielen Dank im Voraus!!!!
Anja
Private Sub cmdImport_Click()
On Error Resume Next
'ActiveSheet.ShowAllData
'ActiveSheet.Range("A16:S30000").EntireRow.Hidden = False
'ActiveSheet.Range("A16:S30000").FormatConditions.Delete
On Error GoTo errExit
Dim wbQuelle As Workbook, Quelle As Worksheet, Ziel As Worksheet
Dim Datei As Variant, varDateien
Dim Zeile_Z As Long, Zeile_S1 As Long, Zeile_S2 As Long
Dim rngZelle As Range
Dim lngAnzahl As Long
Dim lngLastQ As Long
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
varDateien = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", _
Title:="Bitte zu importieren Datei(en) auswählen", MultiSelect:=True)
' For lngAnzahl = LBound(varDateien) To UBound(varDateien)
'Abbrechen falls keine Datei ausgewählt
If Not IsArray(varDateien) Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
' Inhalt Zeilen löschen
ThisWorkbook.Worksheets("Test").Range("A16:S20000").ClearContents
' Worksheets("Test").Range("A16:T20000").entirerows
' Zieldatei
Set Ziel = ThisWorkbook.Worksheets("Test")
With Ziel
'Startzeile setzen
Set rngZelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
Zeile_Z = 14
Else
Zeile_Z = rngZelle.Row
End If
If Zeile_Z = Zeile_S1 Then
'kopieren und einfügen
' ' .Range(.Rows(Zeile_S1), .Rows(Zeile_S2)).Copy Ziel.Cells(Zeile_Z, 1)
' ############# Bisher verwendeter Code ##########################
' .Range(.Cells(Zeile_S1, 1), .Cells(Zeile_S2, 39)).Copy Ziel.Cells(Zeile_Z, 1)
' ############# Mein neuer Code, mit der Fehlermeldung ##########################
.Range(.Cells(Zeile_S1, 1), .Cells(Zeile_S2, 39)).Copy Ziel
.Cells(Zeile_Z, 1).PasteSpecial xlPasteValues
'nächste Einfügezeile
Zeile_Z = Zeile_Z + Zeile_S2 - Zeile_S1 + 1
End If
End With
'Sheets("Gläubigerdaten").Rows("13:2000").Copy
' Sheets("Gläubigerdaten").Rows("13:2000").PasteSpecial xlPasteValues
NextDatei:
wbQuelle.Close savechanges:=False
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Next Datei
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
MsgBox "FehlerNr.: " & .Number & vbNewLine & vbNewLine _
& "Beschreibung: " & .Description, _
vbCritical, "Fehler"
End Select
End With
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Set Ziel = Nothing
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
MsgBox "Es werden " & UBound(varDateien) & " Dateien eingefügt.", 64
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
' Call Makro_Sortieren
End Sub