Fehler im Kopiermakro

Option Explicit Sub Auswertung() Dim LzA2 As Long Dim LzA30 As Long Dim Lz As Long Application.ScreenUpdating = False LzA2 = Cells(Rows.Count, 2).End(xlUp).Row LzA30 = Cells(Rows.Count, 30).End(xlUp).Row Lz = Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row Range(Cells(1, 1), Cells(LzA2, 26)).Select Selection.ClearContents Range(Cells(4, 29), Cells(LzA30, 40)).Select Selection.ClearContents Sheets("Tabelle1").Range(Cells(1, 1), Cells(Lz, 26)).Copy Sheets("Auswertung"). _ Range(Cells(1, 1), Cells(Lz, 26)) Range("A1").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Walter,
ungetestet!

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Auswertung()
  Dim objSh As Worksheet
  Dim LzA2 As Long, LzA30 As Long, Lz As Long
  With Sheets("Auswertung")
    If SheetExist(.Range("H20").Text) Then
      Set objSh = Sheets(.Range("H20").Text)
      LzA2 = .Cells(.Rows.Count, 2).End(xlUp).Row
      LzA30 = Application.Max(4, .Cells(.Rows.Count, 30).End(xlUp).Row)
      Lz = objSh.Cells(Rows.Count, 2).End(xlUp).Row
      
      .Range(.Cells(1, 1), .Cells(LzA2, 26)).ClearContents
      .Range(.Cells(4, 29), Cells(LzA30, 40)).ClearContents
      
      objSh.Range(objSh.Cells(1, 1), objSh.Cells(Lz, 26)).Copy .Cells(1, 1)
      .Range("A1").Select
    Else
      MsgBox "Das Tabellenblatt '" & .Range("H20").Text & "' gibt's nicht!"
    End If
  End With
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

« Gruß Sepp »

Sub Auswertung() Dim objSh As Worksheet Dim LzA2 As Long, LzA30 As Long, Lz As Long With Sheets("Auswertung") If SheetExist(.Range("H20").Text) Then .Unprotect Set objSh = Sheets(.Range("H20").Text) LzA2 = .Cells(.Rows.Count, 2).End(xlUp).Row LzA30 = Application.Max(4, .Cells(.Rows.Count, 30).End(xlUp).Row) Lz = objSh.Cells(Rows.Count, 2).End(xlUp).Row .Range(.Cells(1, 1), .Cells(LzA2, 26)).ClearContents .Range(.Cells(4, 29), Cells(LzA30, 40)).ClearContents objSh.Range(objSh.Cells(1, 1), objSh.Cells(Lz, 26)).Copy .Cells(1, 1) .Range("A1").Select .Protect Else MsgBox "Das Tabellenblatt '" & .Range("H20").Text & "' gibt's nicht!" End If End With End Sub

Option Explicit Sub Auswertung() Dim LzA2 As Long Dim LzA30 As Long Dim Lz As Long Application.ScreenUpdating = False LzA2 = Cells(Rows.Count, 2).End(xlUp).Row LzA30 = Cells(Rows.Count, 30).End(xlUp).Row Lz = Sheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row Range(Cells(1, 1), Cells(LzA2, 26)).ClearContents Range(Cells(4, 29), Cells(LzA30, 40)).ClearContents With Sheets(Worksheets("Auswertung").Range("H20")) .Range(.Cells(1, 1), .Cells(Lz, 26)).Copy Sheets("Auswertung"). _ Range(Cells(1, 1), Cells(Lz, 26)) End With End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread