Microsoft Excel

Herbers Excel/VBA-Archiv

Makro für Vergleich + neues Blatt erzeugen | Herbers Excel-Forum


Betrifft: Makro für Vergleich + neues Blatt erzeugen von: Bibabutzel
Geschrieben am: 14.01.2010 00:43:15

Hallo zusammen,

wäre bitte jemand so lieb und würde mir für folgendes Problem mit einem Makro "aushelfen"?

Ich habe zwei Tabellenblätter (Blatt1 und Blatt2). In Blatt1 sollen in Spalte A jeweils 10 zusammengehörige Zeilen mit Namen befüllt werden, die in regelmäßigen Abständen angeordnet sind (also A10:20; A15:25; A30:40, u.s.w.). In Blatt2 gibt es einen fest definierten Bereich (A1:A30) in dem auch Namen stehen bzw. stehen sollen. Das Makro soll jetzt folgendes machen: sobald sich in einem der Namensbereiche aus Blatt1 etwas ändert (also ein Name hinzugefügt oder geändert wird) soll geprüft werden, ob dieser Name schon im Bereich A1:30 von Blatt2 vorhanden ist. Wenn der Name dort nicht drin steht, soll er dort hinzugefügt werden (in die erste freie Zelle) und es soll ein neues Tabellenblatt erzeugt werden (durch kopieren eines schon vorhandenden Tabellenblattes Blatt3). Das neue Tabellenblatt soll nach seinem "Erzeuger" benannt werden, also den Namen bekommen, der in Blatt2 nicht in der Liste stand und Auslöser für die Erstellung war. Wenn der Name aus Blatt1 dagegen schon in der Liste von Blatt2 stehen sollte, soll gar nichts passieren.

Ich danke schon jetzt allen, die sich beteiligen und mir Hilfestellung leisten, ganz herzlich im voraus!

Liebe Grüsse
Bibabutzel

  

Betrifft: AW: Makro für Vergleich + neues Blatt erzeugen von: Josef Ehrensberger
Geschrieben am: 14.01.2010 01:08:58

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



  

Betrifft: AW: Makro für Vergleich + neues Blatt erzeugen von: Bibabutzel
Geschrieben am: 14.01.2010 09:59:41

Hallo Josef,

erstmal vielen, vielen Dank für Deine Antwort und die Arbeit, die Du Dir gemacht hast. Ich habe das Makro 1 zu 1 übernommen und es läuft ganz prima - bis auf eine klitzekleine Kleinigkeit:

Ich hatte mich in meinem Posting verschrieben. Und zwar beginnt der fest definierte Bereich auf Blatt2 (in den die nicht vorhandenen Namen eingetragen werden sollen) nicht bei A1 sondern bei A10 (die Null ist mir wohl durchgerutscht) und nun trägt das Makro natürlich die Namen schon über den "Zielbereich" ein. Kannst Du mir hier bitte nochmal behilflich sein und mir sagen, was ich an dem Makro ändern muss, damit wirklich nur der Bereich ab A10 (bis max. A30) ausgefüllt wird?

1000 Dank vorab + herzliche Grüsse
Bibabutzel


  

Betrifft: AW: Makro für Vergleich + neues Blatt erzeugen von: Josef Ehrensberger
Geschrieben am: 14.01.2010 10:08:54

Hallo ???,

ändere die Zeile

Sheets("Blatt2").Range("A" & Sheets("Blatt2").Cells(Rows.Count, 1).End(xlUp).Row + 1) = .Value

ab in
Sheets("Blatt2").Range("A" & Application.Max(10, Sheets("Blatt2").Cells(Rows.Count, 1).End(xlUp) _
.Row + 1)) = .Value

Gruß Sepp



  

Betrifft: AW: Makro für Vergleich + neues Blatt erzeugen von: Bibabutzel
Geschrieben am: 14.01.2010 21:08:15

Hallo Josef,

nochmal Danke für die schnelle Antwort und die zügige Hilfe. Musste heute arbeiten, deshalb erst jetzt meine Antwort.

Leider hat sich mit der Änderung der Makro-Zeile nur eine weitere Merkwürdigkeit ergeben. Wenn ich nämlich jetzt aus Blatt1 einen Namen lösche, dann wird ein weiteres neues Tabellenblatt erzeugt (Blatt3 (2)). Beim Löschen eines Namens ist dies aber nicht notwendig. Und das alte Problem ist leider auch geblieben: die Namen werden immernoch vor Zeile 10 eingefügt. Vielleicht habe ich Dir auch unabsichtlich(!) ein wichtiges Detail verschwiegen: Die Zeilen A10:A30 in Blatt2 (also die, wo die Namen rein sollen) sind gruppiert und ausgblendet (über das kleine Minuszeichen an der Seite). Keine Ahnung ob das eine Rolle spielt; wenn ja, große Entschuldigung dafür.

Würdest Du bitte trotzdem nochmal drüber schauen, ob sich da was machen lässt?

wie immer: Danke, Danke vorab!
Bibabutzel


  

Betrifft: AW: Makro für Vergleich + neues Blatt erzeugen von: Bibabutzel
Geschrieben am: 14.01.2010 21:51:59

Hi Josef,

ich bin's gleich nochmal. Der Fehler, dass vor Zeile 10 eingefügt wird ist hinfällig! Ich bin sooo ein Idiot! Die Zellen waren befüllt (Schriftfarbe weiß(!)). Ich bin drauf gekommen, weil ich die Tabelle jetzt nochmal umbasteln musste/wollte.
Dafür habe ich ein anderes Problem gefunden: Wenn ich eine Namensliste in Blatt1 kopiere, dann wird nur der erste Name dieser Liste in Blatt2 übernommen und es wird - folgerichtig - auch nur ein neues Tabellenblatt erzeugt. Also um den aktuellen (Problem)Stand nochmal kurz auf den Punkt zu bringen:

1. durch den Umbau der Tabelle soll jetzt in Blatt2 nicht mehr ab Zeile 10 sondern ab Zeile 20 eingefügt werden
2. wenn ich in Blatt1 einen Namen lösche, wird (unnötigerweise) ein weiteres Tabellenblatt erzeugt (Blatt3(2))
3. wenn ich mehrere Namen (durch kopieren) gleichzeitig in Blatt1 eintrage, wird in Blatt2 nur der erste Name übernommen und nur ein neues Blatt erzeugt

Ich hoffe, ich gehe Dir nicht langsam auf den "Wecker"... Hast Du noch Lust, Zeit und Energie für Hilfe?

Merci + viele Grüsse
Bibabutzel


  

Betrifft: AW: Makro für Vergleich + neues Blatt erzeugen von: Josef Ehrensberger
Geschrieben am: 14.01.2010 22:43:00

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



  

Betrifft: AW: Makro für Vergleich + neues Blatt erzeugen von: Mirko
Geschrieben am: 14.01.2010 23:17:51

Lieber Sepp,

Habe vielen, vielen Dank für Deine Geduld, Hilfsbereitschaft und LÖSUNG! Jetzt scheint alles zu laufen. Als "Dankeschön" gibt's auch den hartnäckig aber freundlich geforderten Namen ;-)

Liebe Grüsse!


Beiträge aus den Excel-Beispielen zum Thema "Makro für Vergleich + neues Blatt erzeugen"