Makro für Vergleich + neues Blatt erzeugen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Du, mit dem eigenartigen Namen,
der Code gehört in das Modul von Blatt1.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim objSh As Worksheet
  Dim vntRet As Variant

  On Error GoTo ErrExit

  With Target(1, 1)
    If .Column = 1 Then
      Select Case .Row
        Case 10 To 20, 25 To 35, 40 To 50 'hier die Blöcke (Zeilen) angeben!
          vntRet = Application.Match(.Value, Sheets("Blatt2").Range("A:A"), 0)
          If Not IsNumeric(vntRet) Then
            Application.ScreenUpdating = False
            Sheets("Blatt2").Range("A" & Sheets("Blatt2").Cells(Rows.Count, 1).End(xlUp).Row + 1) = .Value
            If Not SheetExist(.Value) Then
              Sheets("Blatt3").Copy After:=Sheets(Sheets.Count)
              Sheets(Sheets.Count).Name = .Value
              Me.Activate
            End If
          End If
        Case Else
      End Select
    End If
  End With

  ErrExit:
  Application.ScreenUpdating = True
  Set objSh = Nothing
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 wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp

Hallo Du, der seinen namen nicht veraten will.
Auf den "Wecker" gehst du mir nicht, ich muss ja nicht antworten, wenn ich nicht will ;-))
Es ist nur angenehmer, wenn man alle Infos auf einmal, zu Beginn des Threads erhält.
Das sollte es tun.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim objSh As Worksheet, rng As Range
  Dim vntRet As Variant

  On Error GoTo ErrExit

  If Target.Column = 1 Then
    For Each rng In Intersect(Target, Columns(1))
      If rng <> "" Then
        Select Case rng.Row
          Case 10 To 20, 25 To 35, 40 To 50 'hier die Blöcke (Zeilen) angeben!
            vntRet = Application.Match(rng.Value, Sheets("Blatt2").Range("A20:A" & _
              Application.Max(20, Sheets("Blatt2").Cells(Rows.Count, 1).End(xlUp).Row)), 0)
            If Not IsNumeric(vntRet) Then
              Application.ScreenUpdating = False
              Sheets("Blatt2").Range("A" & Application.Max(20, Sheets("Blatt2").Cells(Rows.Count, _
                1).End(xlUp).Row + 1)) = rng.Value
              If Not SheetExist(rng.Value) Then
                Sheets("Blatt3").Copy After:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = rng.Value
                Me.Activate
              End If
            End If
          Case Else
        End Select
      End If
    Next
  End If

  ErrExit:
  Application.ScreenUpdating = True
  Set objSh = Nothing
  Set rng = Nothing
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 wks.Name = sheetName Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Makro für Vergleich + neues Blatt erzeugen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread