Makro ausbauen

Sub Daten_holen_01() Dim lngZ As Long With Application .DisplayAlerts = False '.ScreenUpdating = False End With lngZ = 1 Workbooks.Open Filename:="T:\Eigene Dateien\01.xls" Windows("01.xls").Activate Range("F6:F71,N6:N71").Select Selection.Copy Windows("Test.xlsm").Activate Sheets("Test").Cells(lngZ, 1).PasteSpecial xlValues Windows("01.xls").Close False With Application .DisplayAlerts = True '.ScreenUpdating = True .CutCopyMode = False End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Snewi,
gehe davon aus, dass in A1 ein "echte" Datum steht!

Sub Daten_holen()
  Dim objWB As Workbook, objSh As Worksheet, objTarget As Worksheet
  Dim lngZ As Long, strMonth As String
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  lngZ = 1
  
  With ThisWorkbook
    strMonth = Format(.Sheets("Zeidaten").Range("A1"), "MM-yyyy")
    
    Set objWB = Workbooks.Open(Filename:="T:\Eigene Dateien\01.xls")
    For Each objSh In objWB.Worksheets
      If objSh.Name = strMonth Then
        Set objTarget = objSh
        Exit For
      End If
    Next
    
    If Not objTarget Is Nothing Then
      objTarget.Range("F6:F71,N6:N71").Copy
      .Sheets("Test").Cells(lngZ, 1).PasteSpecial xlValues
    End If
    
    objWB.Close False
  End With
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'Daten_holen'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul3"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
  Set objWB = Nothing
  objSh = Nothing
  objTarget = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread