Thema: Werte prüfen und kopieren

StandardModule: basMain

Sub MatchCopy()
   Dim var As Variant
   Dim lRowL As Integer, lRow As Integer, lRowD, lRowS As Long
   Dim bln As Boolean
   lRowL = Cells(Rows.Count, 2).End(xlUp).Row
   For lRow = 1 To lRowL
      bln = False
      If Not IsEmpty(Cells(lRow, 1)) Then
         var = Application.Match(Cells(lRow, 1), _
            Worksheets("Ziel").Columns("A"), 0)
      Else
         Cells(lRow, 1).Value = WorksheetFunction.Max(Columns(1)) + 1
         bln = True
      End If
      If IsError(var) Or bln = True Then
         With Worksheets("Ziel")
            If IsEmpty(.Cells(1, 1)) Then
               lRowS = 1
            Else
               lRowS = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            End If
            .Range(.Cells(lRowS, 1), .Cells(lRowS, 4)).Value = _
               Range(Cells(lRow, 1), Cells(lRow, 4)).Value
         End With
      Else
         With Worksheets("Vorhanden")
            If IsEmpty(.Cells(1, 1)) Then
               lRowD = 1
            Else
               lRowD = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            End If
            .Range(.Cells(lRowD, 1), .Cells(lRowD, 4)).Value = _
               Range(Cells(lRow, 1), Cells(lRow, 4)).Value
         End With
      End If
   Next lRow
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Kopieren