Laufzeitfehler 13

Sub Übertrag() Application.ScreenUpdating = False ' Tabelle: Quelle ' Tabelle Ziel: Ziel ' Kopiert die SoD-Konflikte von Quelle in das Dashboard Const Blatt1 = "Quelle" ' Source Const Blatt2 = "Ziel" ' Ziel Dim I As Integer Dim iAnz As Integer Dim letzte As Long ' ermittelt die letzte befüllte Zelle Worksheets("Ziel").Activate letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row ' ermittelt die letzte befüllte Zelle ' Markiert und löscht den Bereich Worksheets("Ziel").Range("A13:AA" & letzte).Clear ' Kopiert die Überschrift Worksheets("Quelle").Range("A3:E3").Copy Worksheets("Ziel").Activate Range("A3").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Worksheets("Ziel").Range("A13").Activate Sheets(Blatt1).Activate Range("A10").Select iAnz = 0 I = 0 Do Until I = ActiveSheet.UsedRange.Rows.Count If ActiveCell.Value = Range("B" & 5).Value Then Selection.EntireRow.Copy Sheets(Blatt2).Activate ActiveSheet.Paste ActiveCell.Offset(1, 0).Select Sheets(Blatt1).Select ActiveCell.Offset(1, 0).Select iAnz = iAnz + 1 Else ActiveCell.Offset(1, 0).Select End If I = I + 1 Loop MsgBox "Es wurden " & iAnz & " Sätze übertragen" Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Sorry, ich nehme an der Code wurde mit Makro Recorder aufgezeichnet. man kann ihn professioneler gestalten.
Anbei ein Lösungsversuch von mir, würde mich freuen wenn es klappt.
Für VBA Anfaenger verwirrend ist die Kombination von If mit ElseIf um Fehler abzufangen!! Was passiert da?
Ist die If Bedingung erfüllt - passiert garnichts! Die ElseIf wird aber - NICHT mehr ausgeführt! Ein simpler Trick!
Der Rest ist bekannt, aber auf Select, vor allem auf Blatt Selekt kann man verzichten!! Ich nahme hier lieber For Next als Do Loop, weil es sich einfach von selbst anbietet. Ich hoffe das Makro ist so simpel geschrieben das du es verstehen kannst. Ansonsten freue dich wenn es funktioniert.
Frohe Weihnachten und ein gutes neues Jahr ...
mfg Piet

Sub Übertrag()
Application.ScreenUpdating = False
' Tabelle: Quelle
' Tabelle Ziel: Ziel
' Kopiert die SoD-Konflikte von Quelle in das Dashboard
Const Blatt1 = "Quelle"           ' Source
Const Blatt2 = "Ziel" ' Ziel
Dim I As Integer
Dim iAnz As Integer
Dim letzte As Long
' löscht den UsedRange der Ziel Tabelle
Worksheets("Ziel").UsedRange.Clear
'** diese Variante laesst die 1. Zeiele als Überschrifts bestehen !!
Worksheets("Ziel").UsedRange.Offset(1#).Clear
' Kopiert die Überschrift  (direkt dranhaengen!!
Worksheets("Quelle").Range("A3:E3").Copy _
Worksheets("Ziel").Range("A3")
Sheets(Blatt2).Activate
z2 = ActiveSheet.ActiveCell.Row
Sheets(Blatt1).Activate
Range("A10").Select
For I = 10 To ActiveSheet.UsedRange.Rows.Count
'If InStr(Cells(I, 1), "#") Then
If IsError(Cells(I, 1)) Then
ElseIf Cells(I, 1) = Range("B5") Then
Rows(I).Copy
Sheets(Blatt2).Rows(x2).PasteSpecial xlPasteAll
z2 = z2 + 1
End If
Next I
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Es wurden " & iAnz & " Sätze übertragen"
End Sub

Sub Übertrag() Application.ScreenUpdating = False ' Tabelle: Quelle ' Tabelle Ziel: Ziel ' Kopiert die SoD-Konflikte von Quelle in das Dashboard Const Blatt1 = "Quelle" ' Source Const Blatt2 = "Ziel" ' Ziel Dim I As Integer Dim iAnz As Integer Dim letzte As Long ' löscht den UsedRange der Ziel Tabelle Worksheets("Ziel").UsedRange.Clear '** diese Variante laesst die 1. Zeiele als Überschrifts bestehen !! Worksheets("Ziel").UsedRange.Offset(1#).Clear ' Kopiert die Überschrift (direkt dranhaengen!! Worksheets("Quelle").Range("A3:E3").Copy _ Worksheets("Ziel").Range("A3") Sheets(Blatt2).Activate z2 = ActiveSheet.ActiveCell.Row Sheets(Blatt1).Activate Range("A10").Select For I = 10 To ActiveSheet.UsedRange.Rows.Count 'If InStr(Cells(I, 1), "#") Then If IsError(Cells(I, 1)) Then ElseIf Cells(I, 1) = Range("B5") Then Rows(I).Copy Sheets(Blatt2).Rows(x2).PasteSpecial xlPasteAll z2 = z2 + 1 End If Next I Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Es wurden " & iAnz & " Sätze übertragen" End Sub

Hallo Matthias,
da ich deine Mappe nicht kenne, kann ich manche Zeilen nur erraten. Und bei einer steh ich auf dem Schlauch:
If .Cells(lngRow, 1).Value = .Range("B5").Value Then ' ?
bei dir:
If ActiveCell.Value = Range("B" & 5).Value Then
Teste mal (aber bitte in einer Kopie der Originalmappe !!!):

Option Explicit

Public Sub Übertrag()

    ' Kopiert die SoD-Konflikte von Quelle in das Dashboard

    Const SOURCE_SHEET As String = "Quelle"
    Const TARGET_SHEET As String = "Ziel"

    Dim lngRow As Long, lngCopyRow As Long

    Application.ScreenUpdating = False

    ' löscht den UsedRange der Ziel Tabelle
    With Worksheets(TARGET_SHEET)
        Call .Range(.Cells(3, 1), .Cells( _
            .Cells(.Rows.Count, 1).End(xlUp).Row, 27)).Clear
    End With

    ' Kopiert die Überschrift (direkt dranhaengen!!
    Call Worksheets(SOURCE_SHEET).Range("A3:E3").Copy( _
        Destination:=Worksheets(TARGET_SHEET).Range("A3"))

    lngCopyRow = 4

    With Worksheets(SOURCE_SHEET)

        For lngRow = 10 To .Cells(.Rows.Count, 1).End(xlUp).Row

            If Not IsError(.Cells(lngRow, 1).Value) Then

                If .Cells(lngRow, 1).Value = .Range("B5").Value Then ' ?

                    Call .Rows(lngRow).Copy(Destination:= _
                        Sheets(TARGET_SHEET).Rows(lngCopyRow))

                    lngCopyRow = lngCopyRow + 1

                End If
            End If
        Next lngRow
    End With

    Application.ScreenUpdating = True

    Call MsgBox("Es wurden " & CStr(lngCopyRow - 3) & " Datensätze übertragen", _
        vbInformation, "Information")

End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread