Zellen in andere Mappe kopieren per Button

Sub MappeOeffnen() Dim strOrdner As String, strdateiname As String Dim wbMappe As Workbook strOrdner = "C:\Dein\Ordner\" strdateiname = "Auswertung.xls" On Error Resume Next Set wbMappe = Workbooks(strdateiname) If Not wbMappe Is Nothing Then wbMappe.Activate MsgBox "Mappe ist bereits geöffnet !" Else If Dir(strOrdner & strdateiname) "" Then Set wbMappe = Workbooks.Open(strOrdner & strdateiname, UpdateLinks:=False) Else MsgBox "Folgende Datei existiert nicht : " & vbf & vbLf & _ strOrdner & strdateiname, vbOKOnly + vbCritical, "Datei nicht gefunden !" End If End If Set wbMappe = Nothing --> Bis hier TOP !!! Aber Kopiervorgang klappt nicht. Workbooks("MappeA.xls").Sheets("SheetA").Range("F10:H22").Copy Workbooks("MappeB.xls").Sheets("SheetB").Range("C10").PasteSpecial xlPasteValues End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub MappeOeffnen() Dim strOrdner As String, strdateiname As String Dim wbMappe As Workbook, bolWasOpen As Boolean On Error GoTo ErrExit With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual .DisplayAlerts = False End With strOrdner = "C:\Dein\Ordner\" strdateiname = "Auswertung.xls" bolWasOpen = True On Error Resume Next Set wbMappe = Workbooks(strdateiname) On Error GoTo ErrExit If wbMappe Is Nothing Then bolWasOpen = False If Dir(strOrdner & strdateiname) <> "" Then Set wbMappe = Workbooks.Open(strOrdner & strdateiname, UpdateLinks:=False) Else MsgBox "Folgende Datei existiert nicht : " & vbLf & vbLf & _ strOrdner & strdateiname, vbOKOnly + vbCritical, "Datei nicht gefunden !" End If End If If Not wbMappe Is Nothing Then ThisWorkbook.Sheets("SheetA").Range("F10:H22").Copy wbMappe.Sheets("SheetB").Range("C10").PasteSpecial xlPasteValues If Not bolWasOpen Then wbMappe.Close True End If End If ErrExit: With Err If .Number <> 0 Then MsgBox "Fehler in Prozedur:" & vbTab & "Sub 'MappeOeffnen'" & vbLf & String(40, "=") & vbLf & vbLf & _ IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _ .Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation, "Fehler in Modul - Modul3" .Clear End If End With On Error GoTo 0 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic .DisplayAlerts = True End With Set wbMappe = Nothing End Sub

Sub LadeButton_Click() Dim strOrdner As String, strdateiname As String Dim wbMappe As Workbook strOrdner = "C:\Dein\Ordner\" strdateiname = "MappeB.xls" On Error Resume Next Set wbMappe = Workbooks(strdateiname) If Not wbMappe Is Nothing Then wbMappe.Activate MsgBox "Mappe ist bereits geöffnet !" Else 'Wenn Mappe noch nicht geöffnet ist If Dir(strOrdner & strdateiname) "" Then Set wbMappe = Workbooks.Open(strOrdner & strdateiname, UpdateLinks:=False) Else MsgBox "Folgende Datei existiert nicht : " & vbf & vbLf & _ strOrdner & strdateiname, vbOKOnly + vbCritical, "Datei nicht gefunden !" End If End If If Not wbMappe Is Nothing Then ThisWorkbook.Sheets("SheetA").Range("A17:D17").Copy wbMappe.Sheets("SheetB").Range("B20:E20").PasteSpecial xlPasteValues End If 'Speicher für Objektvariable wieder freigeben : Set wbMappe = Nothing End Sub

Hallo Erik,
gefällt dir meine Fehlerbehandlung nicht?

Sub MappeOeffnen()
  Dim strOrdner As String, strdateiname As String
  Dim wbMappe As Workbook, bolWasOpen As Boolean
  Dim lngNext As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  strOrdner = "C:\Dein\Ordner\"
  strdateiname = "Auswertung.xls"
  bolWasOpen = True
  
  On Error Resume Next
  Set wbMappe = Workbooks(strdateiname)
  On Error GoTo ErrExit
  If wbMappe Is Nothing Then
    bolWasOpen = False
    If Dir(strOrdner & strdateiname) <> "" Then
      Set wbMappe = Workbooks.Open(strOrdner & strdateiname, UpdateLinks:=False)
    Else
      MsgBox "Folgende Datei existiert nicht : " & vbLf & vbLf & _
        strOrdner & strdateiname, vbOKOnly + vbCritical, "Datei nicht gefunden !"
    End If
  End If
  
  If Not wbMappe Is Nothing Then
    With wbMappe.Sheets("SheetB")
      lngNext = Application.Max(10, .Cells(.Rows.Count, 3).End(xlUp).Row + 1)
      ThisWorkbook.Sheets("SheetA").Range("F10:H22").Copy
      .Cells(lngNext, 3).PasteSpecial xlPasteValues
    End With
    If Not bolWasOpen Then
      wbMappe.Close True
    End If
  End If
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "Sub 'MappeOeffnen'" & vbLf & String(40, "=") & vbLf & vbLf & _
        IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
        .Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation, "Fehler in Modul - Modul3"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
  End With
  
  Set wbMappe = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Zellen in andere Mappe kopieren per Button

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen in andere Mappe kopieren per Button

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread