Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 21:09:11
4 Spalten aus smarter Tabelle in andere smarte Tab. kopieren
18.04.2024 20:45:35
Worksheet_Activate für alle Sheets
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1228to1232
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1228to1232
1228to1232
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Makroerweiterung

Makroerweiterung
Ernst
Guten Morgen !
würde mal wieder eure Hilfe brauchen.
Ich habe folgendes bestehendes Makro das mich auf doppelte Einträge aufmerksam macht !
Möchte es gerne erweitern.
1] bei Eingabe eines Wertes üperprüfen ob der Wert in Tabelle 2 a1-a100 vorhanden ist, in Tabelle 2 b1-b100 steht ein Text der den jeweiligen Wert zugeordnet ist.
wenn ja sollte eine msg Box Ausgabe erfolgen die mir den Text anzeigt der dem eingegebenen Wert zugeordnet ist.
bei Zellenwechsel msg Box schließen.
wäre Dankbar wenn mir da jemand helfen könnte.
lg.Ernst

Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSpalte   As Variant  ' die Eingabe- und die zu vergleichenden Spalten
Dim iIndex    As Integer  ' Index für den Spalten-Array
If Target.Count > 1 Then Exit Sub   ' mehr als eine Zelle markiert ?
If Target.Value = "" Then Exit Sub  ' ist die Zelle gefüllt ?
'                  B  C  I   J   P   Q
iSpalte = Array(2, 3, 9, 10, 16, 17) ' die Spalten-Nummern als Array
If Target.Column = 2 Or Target.Column = 3 Or _
Target.Column = 9 Or Target.Column = 10 Or _
Target.Column = 16 Or Target.Column = 17 Then  ' eine gültige Eingabe-Spalte ?
For iIndex = 0 To UBound(iSpalte)          ' alle Spalten abarbeiten/vergleichen
If Target.Column = iSpalte(iIndex) Then ' ist es die Eingabespalte ?
If Application.WorksheetFunction.CountIf(Columns(Target.Column), _
Target.Value) > 1 Then  ' zählen in der Eingabespalte
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
Else                                    ' es ist NICHT die Eingabspalte !
If Application.WorksheetFunction.CountIf(Columns(iSpalte(iIndex)), _
Target.Value) > 0 Then  ' zählen in den NICHT Eingabespalten
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
End If
Next iIndex
End If
End Sub

Makroerweiterung
21.09.2011 12:34:18
Ernst
Guten Morgen !
würde mal wieder eure Hilfe brauchen.
Ich habe folgendes bestehendes Makro das mich auf doppelte Einträge aufmerksam macht !
Möchte es gerne erweitern.
1] bei Eingabe eines Wertes üperprüfen ob der Wert in Tabelle 2 a1-a100 vorhanden ist, in Tabelle 2 b1-b100 steht ein Text der den jeweiligen Wert zugeordnet ist.
wenn ja sollte eine msg Box Ausgabe erfolgen die mir den Text anzeigt der dem eingegebenen Wert zugeordnet ist.
bei Zellenwechsel msg Box schließen.
wäre Dankbar wenn mir da jemand helfen könnte.
lg.Ernst
https://www.herber.de/bbs/user/76711.zip 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSpalte   As Variant  ' die Eingabe- und die zu vergleichenden Spalten
Dim iIndex    As Integer  ' Index für den Spalten-Array
If Target.Count > 1 Then Exit Sub   ' mehr als eine Zelle markiert ?
If Target.Value = "" Then Exit Sub  ' ist die Zelle gefüllt ?
'                  B  C  I   J   P   Q
iSpalte = Array(2, 3, 9, 10, 16, 17) ' die Spalten-Nummern als Array
If Target.Column = 2 Or Target.Column = 3 Or _
Target.Column = 9 Or Target.Column = 10 Or _
Target.Column = 16 Or Target.Column = 17 Then  ' eine gültige Eingabe-Spalte ?
For iIndex = 0 To UBound(iSpalte)          ' alle Spalten abarbeiten/vergleichen
If Target.Column = iSpalte(iIndex) Then ' ist es die Eingabespalte ?
If Application.WorksheetFunction.CountIf(Columns(Target.Column), _
Target.Value) > 1 Then  ' zählen in der Eingabespalte
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
Else                                    ' es ist NICHT die Eingabspalte !
If Application.WorksheetFunction.CountIf(Columns(iSpalte(iIndex)), _
Target.Value) > 0 Then  ' zählen in den NICHT Eingabespalten
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
End If
Next iIndex
End If
End Sub

Anzeige
stehe ich auf einer Blacklist ?
21.09.2011 20:51:39
Ernst
Guten Abend !
Liebe Vba Profis.
Habe ich mein Anliegen schlecht formuliert ?
oder was mache ich falsch,weil niemand auf meine Frage Antwortet.
wäre für Hinweise dankbar.
lg.Ernst
AW: stehe ich auf einer Blacklist ?
22.09.2011 08:07:20
Dirk
Hallo Werner,
wo sollen denn die Wertte zur Ueberpruefung eingegeben werden? Ist das immer dieselbe Zelle oder sollen es unterschiedliche Zellen sein?
Gruss
Dirk aus Dubai
AW: stehe ich auf einer Blacklist ?
22.09.2011 08:09:01
Dirk
Ich meine natuerlich 'Hallo Ernst!' :-)
AW: stehe ich auf einer Blacklist ?
22.09.2011 08:51:31
Dirk
Hallo Ernst,
hier mal ein Beispiel:
https://www.herber.de/bbs/user/76721.xls
Lass' hoeren, ob so ok.
Gruss
Dirk aus Dubai
Anzeige
AW: stehe ich auf einer Blacklist ?
22.09.2011 09:13:57
Dirk
Hallo nochmal,
ersetze bitte das Makro mit den zwei folgenden:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyEntry As Long
Dim EntryField As Range
Dim MyValArr As Variant
Dim i As Long
Set EntryField = Range("B1")
If Target.Address = EntryField.Address And EntryField.Value  0 Then
'Aenderung im Eingabefeld festgestellt
MyEntry = EntryField.Value
With Sheets("Tabelle2")
MyValArr = Sheets("Tabelle2").Range("A1:A100").Value
End With
For i = 1 To 100
If Val(MyEntry) = Val(MyValArr(i, 1)) Then
UF1.Caption = "                  Wert wurde gefunden!"
UF1.BackColor = &HC0FFC0
UF1.Label1.Caption = "Zugeordneter Text:"
UF1.Label2.Caption = Sheets("Tabelle2").Cells(i, 2).Value
UF1.Show vbModeless
Exit For
End If
Next i
If i > 100 Then
UF1.Caption = "                  Wert nicht gefunden!"
UF1.BackColor = &HC0C0FF
UF1.Label1.Caption = ""
UF1.Label2.Caption = "Wert  " & MyEntry & "  nicht in Liste!"
UF1.Show vbModeless
End If
Else
UF1.Hide
End If
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address  Range("B2").Address Then
If UF1.Visible = True Then
UF1.Hide
End If
End If
End Sub
Gruss
Dirk aus Dubai
Anzeige
AW: stehe ich auf einer Blacklist ?
22.09.2011 09:52:23
Ernst
Hallo Dirk !
Also erstmals recht herzlichen für deine Lösung.
genau so habe ich mir das vorgestellt nur wie lässt sich das in mein bestehendes Makro integrieren ?
(Bestehende Abgefragte Range Bereiche sollten gleich bleiben,Hinweis auf doppelten Eintrag sollte erhalten bleiben,in bestehenden abgefragten Range Bereichen sollte das neue Makro ebenfalls zur Anwendung kommen )
Wäre für Lösung Dankbar.
lg.Ernst
AW: stehe ich auf einer Blacklist ?
22.09.2011 11:15:34
Dirk
Hallo!
Zurueck zu meiner unbeantworteten Frage: Soll der Wert nur in einer Zelle ueberprueft werden oder in mehreren Zellen?
Falls mehrere Zellen bitte die Ranges bekanntgeben.
Gruss
Dirk
Anzeige
AW: stehe ich auf einer Blacklist ?
22.09.2011 11:33:04
Ernst
Hallo Dirk !
Danke für die rasche Antwort.
Anbei mein bestehendes Makro das die Range Bereiche beinhaltet.
lg.Ernst

Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSpalte   As Variant  ' die Eingabe- und die zu vergleichenden Spalten
Dim iIndex    As Integer  ' Index für den Spalten-Array
If Target.Count > 1 Then Exit Sub   ' mehr als eine Zelle markiert ?
If Target.Value = "" Then Exit Sub  ' ist die Zelle gefüllt ?
'                  B  C  I   J   P   Q
iSpalte = Array(2, 3, 9, 10, 16, 17) ' die Spalten-Nummern als Array
If Target.Column = 2 Or Target.Column = 3 Or _
Target.Column = 9 Or Target.Column = 10 Or _
Target.Column = 16 Or Target.Column = 17 Then  ' eine gültige Eingabe-Spalte ?
For iIndex = 0 To UBound(iSpalte)          ' alle Spalten abarbeiten/vergleichen
If Target.Column = iSpalte(iIndex) Then ' ist es die Eingabespalte ?
If Application.WorksheetFunction.CountIf(Columns(Target.Column), _
Target.Value) > 1 Then  ' zählen in der Eingabespalte
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
Else                                    ' es ist NICHT die Eingabspalte !
If Application.WorksheetFunction.CountIf(Columns(iSpalte(iIndex)), _
Target.Value) > 0 Then  ' zählen in den NICHT Eingabespalten
If MsgBox("die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?", _
vbYesNo + vbQuestion, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
End If
Next iIndex
End If
End Sub

Anzeige
AW: stehe ich auf einer Blacklist ?
22.09.2011 12:44:56
Dirk
Hallo nochmal,
zusammengefasst:
Du mochtest zusaetzlich zu der Pruefung in Deiner Tabelle auch noch pruefen, ob der Eingabewert in Tabelle2 A1:A100 vorhanden ist und dann Anzeigen, falls ja?
Gruss
Dirk aus Dubai
AW: stehe ich auf einer Blacklist ?
22.09.2011 13:05:33
Dirk
Hallo Ernst,
vieleicht so ohne extra pop-ups?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSpalte   As Variant  ' die Eingabe- und die zu vergleichenden Spalten
Dim iIndex    As Integer  ' Index für den Spalten-Array
Dim MyFind As Range       ' zum Suchen in der Tabelle
Dim MyText As String      ' fuer die MagBox
If Target.Count > 1 Then Exit Sub   ' mehr als eine Zelle markiert ?
If Target.Value = "" Then Exit Sub  ' ist die Zelle gefüllt ?
'                  B  C  I   J   P   Q
iSpalte = Array(2, 3, 9, 10, 16, 17) ' die Spalten-Nummern als Array
If Target.Column = 2 Or Target.Column = 3 Or _
Target.Column = 9 Or Target.Column = 10 Or _
Target.Column = 16 Or Target.Column = 17 Then  ' eine gültige Eingabe-Spalte ?
For iIndex = 0 To UBound(iSpalte)          ' alle Spalten abarbeiten/vergleichen
If Target.Column = iSpalte(iIndex) Then ' ist es die Eingabespalte ?
If Application.WorksheetFunction.CountIf(Columns(Target.Column), _
Target.Value) > 1 Then  ' zählen in der Eingabespalte
'In Tabelle2 nachschauen
With ThisWorkbook.Sheets("Tabelle2").Range("A1:A100").Cells
Set MyFind = .Find(what:=Target.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not MyFind Is Nothing Then
MyText = "Die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ und in  _
Tabelle2 bereits." _
& Chr(10) & "Zugeordneter Text: " & MyFind.Offset(0, 1).Value & vbCrLf &  _
"Wollen Sie den Eintrag trotzdem übernehmen?"
Else
MyText = "Die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?"
End If
End With
If MsgBox(MyText, 36, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
Else                                    ' es ist NICHT die Eingabspalte !
If Application.WorksheetFunction.CountIf(Columns(iSpalte(iIndex)), _
Target.Value) > 0 Then  ' zählen in den NICHT Eingabespalten
'In Tabelle2 nachschauen
With ThisWorkbook.Sheets("Tabelle2").Range("A1:A100").Cells
Set MyFind = .Find(what:=Target.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not MyFind Is Nothing Then
MyText = "Die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ und in  _
Tabelle2 bereits." _
& Chr(10) & "Zugeordneter Text: " & MyFind.Offset(0, 1).Value & vbCrLf &  _
"Wollen Sie den Eintrag trotzdem übernehmen?"
Else
MyText = "Die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ bereits." _
& Chr(10) & "Wollen Sie den Eintrag trotzdem übernehmen?"
End If
End With
If MsgBox(MyText, 36, "    nur zur Sicherheit.") = vbYes Then
Exit Sub
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
Exit For
End If
End If
End If
Next iIndex
End If
End Sub

gruss
Dirk aus Dubai
Anzeige
AW: stehe ich auf einer Blacklist ?
23.09.2011 08:10:40
Ernst
Guten Morgen Dirk !
vorerst Danke für die Mühe.
Ergänzend wollte ich noch Anmerken.
1.Tabellenblatt1 sollte wie bisher mich auf doppelte Einträge aufmerksam machen.
2.sollte ich in Tabellenblatt1 einen Wert eingeben der sich in Tabellenblatt2 (A1-A100) wiederfindet möchte ich den zugeordneten Text(b1-b100) angezeigt bekommen.
3.wenn in Tabellenblatt 1 ein Wert doppelt eingegeben wird und sich gleichzeitig in Tabellenblatt2 a1-a100 wiederfindet sollten beide Infos ausgegeben werden.
4.Die Range bereiche aus dem ursprünglichem Makro sollten beibehalten werden.
lg.Ernst
bekomme bei letzterem Lösungsvorschlag leider einen Syntax Fehler.
MyText = "Die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ und in _
Tabelle2 bereits." _
& Chr(10) & "Zugeordneter Text: " & MyFind.Offset(0, 1).Value & vbCrLf & _
"Wollen Sie den Eintrag trotzdem übernehmen?"
Anzeige
AW: stehe ich auf einer Blacklist ?
23.09.2011 11:44:08
Ernst
Hallo Dirk !
habe den Syntaxfehler selbst beheben können:
lag daran.
MyText = "Die Eingabe """ & Target.Value & """ gibt es " & _
"in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) & """ und in _Tabelle2 bereits." _
& Chr(10) & "Zugeordneter Text: " & MyFind.Offset(0, 1).Value & vbCrLf & _
"Wollen Sie den Eintrag trotzdem übernehmen?"
es funktioniert jetzt alles 1a,bis auf folgende Anforderung.
nicht nur bei doppelter Eingabe in Tabellenblatt1 eines Wertes der sich in Tabellenblatt2 (A1-A100) wiederfindet möchte ich den zugeordneten Text(b1-b100) angezeigt bekommen.
lg.Ernst
Anzeige
AW: stehe ich auf einer Blacklist ?
24.09.2011 13:44:50
fcs
Hallo Ernst,
mit etwas anderer Struktur der If-Prüfung und Zwischenberechnung einiger Werte wird es meiner Meinung nach übersichtlicher.
Gruß
Franz

Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSpalte   As Variant  ' die Eingabe- und die zu vergleichenden Spalten
Dim iIndex    As Integer  ' Index für den Spalten-Array
Dim MyFind As Range       ' zum Suchen in der Tabelle
Dim MyText As String      ' fuer die MagBox
Dim sZugeordnet As String ' Einer Eingabespalte zugeordneter Wert
Dim iCount As Integer     ' Anzahl Fundstellen in einer Eingabespalte
If Target.Count > 1 Then Exit Sub   ' mehr als eine Zelle markiert ?
If Target.Value = "" Then Exit Sub  ' ist die Zelle gefüllt ?
'                  B  C  I   J   P   Q
iSpalte = Array(2, 3, 9, 10, 16, 17) ' die Spalten-Nummern als Array
If Target.Column = 2 Or Target.Column = 3 Or _
Target.Column = 9 Or Target.Column = 10 Or _
Target.Column = 16 Or Target.Column = 17 Then  ' eine gültige Eingabe-Spalte ?
'Zum Eingabewert zugeorneter Wert in Tabelle2 Spalte B
With ThisWorkbook.Sheets("Tabelle2").Range("A1:A100").Cells
Set MyFind = .Find(what:=Target.Value, LookIn:=xlValues, lookat:=xlWhole)
End With
If MyFind Is Nothing Then
sZugeordnet = ""
MyText = ""
Else
sZugeordnet = MyFind.Offset(0, 1)
MyText = "Zugeordneter Wert: " & sZugeordnet
End If
For iIndex = 0 To UBound(iSpalte)          ' alle Spalten abarbeiten/vergleichen
'Zählen des Eingabewertes in Spalte iIndex
iCount = Application.WorksheetFunction.CountIf(Columns(iSpalte(iIndex)), _
Target.Value)
If iCount > IIf(Target.Column = iSpalte(iIndex), 1, 0) Then
MyText = MyText & IIf(MyText = "", "", Chr(10)) _
& "Die Eingabe """ & Target.Value & """ gibt es " _
& "in der Spalte """ & Chr(Asc("@") + iSpalte(iIndex)) _
& """ und in Tabelle2 bereits." & Chr(10) & vbCrLf _
& "Wollen Sie den Eintrag trotzdem übernehmen?"
If MsgBox(MyText, 36, "    nur zur Sicherheit.") = vbYes Then
MyText = "":    Exit For
Else
Target.Value = ""                       ' die Eingabe löschen
Cells(Target.Row, Target.Column).Select ' Cursor auf die Eingabezelle
MyText = "":    Exit For
End If
End If
Next iIndex
If MyText  "" Then MsgBox MyText, vbInformation, _
Target.Value & " - Anzeige zugeordneter Wert"
End If
End Sub

Anzeige
Danke:-) perfekt !
24.09.2011 14:39:41
Ernst
recht herzlichen Dank.
lg.Ernst

Links zu Excel-Dialogen

Label

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige