Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
784to788
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
784to788
784to788
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

VBA-Codeanpassung :-( leider drindend

VBA-Codeanpassung :-( leider drindend
22.07.2006 16:26:23
Dirk
Hallo allen EXCEL-Bastlern,
entsprechend beigefügter Beispielmappe habe ich mehrere Fragen - aber zunächst erstmal 2 zur "Einstimmung":
1. Der VBA-Code soll nur auf Blätter beginnend mit "MA0.." (Null) zugreifen, wobei der Registername gemeint ist.
IDEAL wäre, er würde nur die mit "MA" beginnenden durchsuchen - wobei wiederum die mit "MA-" (Minus)ausgeschlossen sein sollen...
2. Nach der Meldung eines doppelten Eintrages sollte in die entsprechende Zeile des Blattes 'doppelte TS' gesprungen werden.
Gesucht werden soll nach doppelten Einträgen in den gelben Bereichen der Blätter "MA0..", wobei nur der doppelte Eintrag in jeweils GLEICHEN ZELLEN gemeldet werden soll.
Wichtig ist auch, daß alle bisherigen Funktionen (zunächstes Zulassen der Eintragung; Warnung beim erneuten Öffnen; Variabilität der Stellung der Register in der Mappe etc.) erhalten bleiben !!!
Kann mir jemand trotz der Hitze helfen ?
MfG Dirk N.
P.S.: Danke allen bisherigen u. zukünftigen Helfern !!!
https://www.herber.de/bbs/user/35295.xls

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA-Codeanpassung :-( leider drindend
22.07.2006 16:52:42
Josef
Hallo Dirk!
Ersetze diesen Code.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim lrow As Long
Dim lcol As Long
Dim Wks As Worksheet
Dim blnDouble As Boolean
Dim rng As Range

lrow = Target.Row
lcol = Target.Column

On Error GoTo ErrExit

If (Left(Sh.Name, 2) = "MA" And InStr(1, Sh.Name, "-") > 0) Or Left(Sh.Name, 2) <> "MA" Then Exit Sub
If Intersect(Target, Range("b26:h31")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub

Application.EnableEvents = False

For Each Wks In ThisWorkbook.Worksheets
  If Not Wks Is Sh Then
    If Left(Wks.Name, 2) = "MA" And InStr(1, Wks.Name, "-") = 0 Then
      If Target = Wks.Cells(lrow, lcol) Then
        blnDouble = True
        With Worksheets("doppelte TS").Cells(100, 1).End(xlUp)
          .Offset(1, 0) = Wks.Name
          .Offset(1, 1) = Target.Address
          .Offset(1, 2) = Target.Value
          .Offset(1, 3) = Target.Worksheet.Name
          .Offset(1, 4) = Target.Address
          Set rng = .Offset(1, 0)
        End With
      End If
    End If
  End If
Next

ErrExit:
Application.EnableEvents = True

If blnDouble Then
  MsgBox "Dieser Tätigkeitsschlüssel existiert bereits" & vbLf & _
    "Genaue Angaben dazu stehen in 'doppelte TS'", vbInformation, "Hinweis"
  Application.Goto rng
End If

End Sub


Gruß Sepp

Anzeige
AW: VBA-Codeanpassung :-( leider drindend
23.07.2006 00:08:31
Dirk
Hallo Sepp,
vielen Dank - funktioniert perfekt !!!
Ich habe die Frage offen gelassen, da noch etwas hinzukommt:
Ist es möglich, daß NACH erfolgter Korrektur in den Blättern "MA0.." AUTOMATISCH die entsprechende ZEILE in 'doppelte TS' gelöscht wird ?
Als VBA-Laie stelle ich mir einen Worksheet-Code im Blatt 'doppelte TS' vor (um die übrige Funktionalität nicht zu beeinträchtigen) - kann es aber leider nicht selber realisieren...
MfG Dirk N.
AW: VBA-Codeanpassung :-( leider drindend
23.07.2006 23:14:51
Horst
Hi,
was soll gelöscht werden, die Zeile oder die Inhalte?
mfg Horst
AW: VBA-Codeanpassung
24.07.2006 09:08:08
Dirk
Hallo Horst,
nach meiner Ansicht wäre wohl das Löschen der Zeile sinnvoller.
So werden Leerzeilen vermieden, die evtl. Schwierigkeiten mit dem bestehenden Code bringen könnten.
Allerdings bin ich VBA-Laie u. lasse mich gern eines Besseren belehren. Wenn es keine Nachteile mit sich bringt u. auch leichter realisierbar ist, so sollte auch das Löschen der Inhalte ausreichend sein.
Vielen Dank für dein Interesse.
MfG Dirk N.
Anzeige
AW: VBA-Codeanpassung
24.07.2006 15:50:07
Horst

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim lrow As Long
Dim lcol As Long
Dim Wks As Worksheet
Dim blnDouble As Boolean
Dim rng As Range
lrow = Target.Row
lcol = Target.Column
On Error GoTo ErrExit
If (Left(Sh.Name, 2) = "MA" And InStr(1, Sh.Name, "-") > 0) Or Left(Sh.Name, 2) <> "MA" Then Exit Sub
If Intersect(Target, Range("b26:h31")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
Application.EnableEvents = False
For Each Wks In ThisWorkbook.Worksheets
If Not Wks Is Sh Then
If Left(Wks.Name, 2) = "MA" And InStr(1, Wks.Name, "-") = 0 Then
If Target = Wks.Cells(lrow, lcol) Then
blnDouble = True
With Worksheets("doppelte TS").Cells(100, 1).End(xlUp)
.Offset(1, 0) = Wks.Name
.Offset(1, 1) = Target.Address
.Offset(1, 2) = Target.Value
.Offset(1, 3) = Target.Worksheet.Name
.Offset(1, 4) = Target.Address
Set rng = .Offset(1, 0)
End With
Wks.Cells(lrow, lcol).EntireRow.Delete
End If
End If
End If
Next
ErrExit:
Application.EnableEvents = True
If blnDouble Then
MsgBox "Dieser Tätigkeitsschlüssel existiert bereits" & vbLf & _
"Genaue Angaben dazu stehen in 'doppelte TS'", vbInformation, "Hinweis"
Application.Goto rng
End If
End Sub

mfg Horst
Anzeige
AW: VBA-Codeanpassung
24.07.2006 20:21:15
Dirk
Hallo Horst,
habe deinen Code übernommen, leider funktioniert es aber noch nicht (d.h. die Zeilen in 'doppelte TS' werden nach einer Korrektur nicht gelöscht).
Hast du deinen Vorschlag mal getestet? Funktioniert es bei dir wie gewünscht?
MfG Dirk N.
AW: VBA-Codeanpassung
24.07.2006 21:16:40
Horst
Hi,
hab das wohl falsch verstanden, bekomme es nicht hin.
mfg Horst
AW: VBA-Codeanpassung
24.07.2006 23:00:35
Dirk
Hallo Horst,
trotzdem vielen Dank für deine Mühe.
MfG Dirk N.
AW: VBA-Codeanpassung :-( leider drindend
24.07.2006 23:24:14
Josef
Hallo Dirk!
Das sollte es tun.
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

'***********************************************************************
'Hier kommt die Warnung das Doppeleinträge in der Mappe sind.

Private Sub Workbook_Open()

If Worksheets("doppelte TS").Cells(3, 1).Value <> "" Then
  MsgBox "Es gibt doppelte Eintragungen in den MA-Blättern!!!"
  MsgBox "Bitte prüfen und nach Korrektur aus Liste in 'doppelte TS' austragen !!!"
End If
End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim lrow As Long
Dim lcol As Long
Dim Wks As Worksheet
Dim blnDouble As Boolean
Dim rng As Range

lrow = Target.Row
lcol = Target.Column

On Error GoTo ErrExit

If (Left(Sh.Name, 2) = "MA" And InStr(1, Sh.Name, "-") > 0) Or Left(Sh.Name, 2) <> "MA" Then Exit Sub
If Intersect(Target, Range("b26:h31")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub

Application.EnableEvents = False

For Each Wks In ThisWorkbook.Worksheets
  If Not Wks Is Sh Then
    If Left(Wks.Name, 2) = "MA" And InStr(1, Wks.Name, "-") = 0 Then
      If Target = Wks.Cells(lrow, lcol) Then
        blnDouble = True
        With Worksheets("doppelte TS").Cells(100, 1).End(xlUp)
          .Offset(1, 0) = Wks.Name
          .Offset(1, 0).Hyperlinks.Add Anchor:=.Offset(1, 0), _
            Address:="", _
            SubAddress:="'" & Wks.Name & "'!" & Target.Address
          .Offset(1, 1) = Target.Address
          .Offset(1, 2) = Target.Value
          .Offset(1, 3) = Target.Worksheet.Name
          .Offset(1, 3).Hyperlinks.Add Anchor:=.Offset(1, 3), _
            Address:="", _
            SubAddress:="'" & Target.Worksheet.Name & "'!" & Target.Address
          .Offset(1, 4) = Target.Address
          Set rng = .Offset(1, 0)
        End With
      End If
    End If
  End If
Next
resetTable
ErrExit:
Application.EnableEvents = True

If blnDouble Then
  MsgBox "Dieser Tätigkeitsschlüssel existiert bereits" & vbLf & _
    "Genaue Angaben dazu stehen in 'doppelte TS'", vbInformation, "Hinweis"
  Application.Goto rng
End If

End Sub


Private Sub resetTable()
Dim rng As Range, rngDel As Range

On Error Resume Next

With Sheets("doppelte TS")
  For Each rng In .Range("A3:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
    If Sheets(rng.Text).Range(rng.Offset(0, 1).Text) <> Sheets(rng.Offset(0, 3).Text).Range(rng.Offset(0, 4).Text) Then
      If rngDel Is Nothing Then
        Set rngDel = rng.EntireRow
      Else
        Set rngDel = Union(rngDel, rng.EntireRow)
      End If
    End If
  Next
End With

If Not rngDel Is Nothing Then rngDel.Delete

On Error GoTo 0

End Sub


Gruß Sepp

Anzeige
AW: VBA-Codeanpassung
24.07.2006 23:53:50
Dirk
Hallo Sepp,
zwar verstehe ich nicht, wie du das mal wieder gezaubert hast, aber es funktioniert super !!!
Und deine Ergänzung (Hyperlink in 'doppelte TS') ist nahezu genial - sozusagen das Sahnehäubchen. Absolute Oberklasse.
Vielen Dank u. vielleicht bis bald mal wieder...
MfG Dirk
P.S.: Zwar tüftle ich schon an der nächsten Sache, aber das gehört nicht in diesen Thread u. ich will es auch erst selber versuchen.

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige