Inhalt einer Zelle vergleichen mit einer Liste

Question

Hallo,

ich bräuchte nen VBA code für Exel wie ich aus einer mappe1 mit
tabelle1 eine Zelle auslesen kann und deren Inhalt vergleiche mit
mappe2 tabelle2, Bereich A5:A30.

Wenn gewünschte Zeile gefunden wird soll diese dann meine neue Zeile
sein mit der ich arbeiten kann.

Ich habe hier bereits einen Code gefunden der nicht schlecht ist,
allerdings bleibt dieser nicht an der Stelle wo er die Zelle gefunden hat:


Private Sub Vergleich

Dim Zeile As Integer
Dim ErrNr As Integer

Zeile = 1
ErrNr = 0

Do While Cells(Zeile, 1).Value <> ""

If Range("B1").Value = Cells(k, 1).Value Then

ErrNr = ErrNr + 1
End If
Zeile = Zeile + 1
Loop

If ErrNr = 0 Then
MsgBox "Wert nicht in Liste enthalten", vbCritical, "Fehler"
Exit Sub
End If
'anderer Code
End Sub



Hat jemand eine Idee?

Answer 1

Hallo,

bist du sicher, dass du das so haben willst? Das wären 3 x 42 Datensätze, insgesamt also 126 Datensätze (von welcher Länge)? Und um das alles einigermaßen Lesen zu können braucht
man auch noch ein Trennzeichen zwischen den einzelnen Daten. Meines Wissens kann eine Messagebox höchstens 1024 Zeichen darstellen. Wird der Text länger müsstest du das mit einer Userform und einer Textbox lösen.
Und wird das einer wirklich alles Vergleichen?

Gruß

M.O.

Answer 2

mhhh dann vielleicht mit einer Userform? Wie würde das in Excel dann aussehen?

Die Sache ist dass das tatsächlich alles einer ansehen würde.

Man könnte das ganze allerdings auch verkürzen auf die wichtigsten 7-8 Zellen pro Zeile, wären dann gesamt 21-24 Datensätze.

Was wäre also besser?

Answer 3

Hallo,

was besser ist, musst letzten Endes du entscheiden.

Eine Userform kannst du nach deinen Bedürfnissen anpassen, die musst du aber selbst entwerfen.
Siehe mal z.B. hier.

Gruß

M.O.

Answer 4

müsste ich in der Userform dann die einzulesende Datei auswählen? Und müsste ich dann Quasi für jeden Datensatz eine Textbox erstellen?

Answer 5

Ich denke es ist in diesem Fall doch besser wenn das alles über die Messengerbox geht.
Kannst du mir da noch evtl. helfen bei dem gestrigen code?

Zeilen wären: A4, J4, K4, AK4, AL4, AM4, AN4, AO4, AP4 von der Quelltabelle
und bei der Zieldatei die selben, bloß dass sich die Zeilen hier wieder nach der ID richten müssen welche in A4 steht.

Ich denke Die beschriftung könnte ich dann selbst erledigen?

Answer 6

Hallo,

hier der geänderte Code:

Public Sub Import_xlph()

Dim vntZuOeffnendeDatei As Variant
Dim Quelle As String
Dim gefunden As Boolean
Dim suchzelle As Range
Dim rueckgabe
Dim textalt As String
Dim textneu As String
Dim sp As Long

'pop-up Fenster zum auswählen der Quelldatei.
vntZuOeffnendeDatei = Application.GetOpenFilename("Excel Dateien (*.xls*), *.xls*")

If vntZuOeffnendeDatei = False Then Exit Sub

Application.ScreenUpdating = False

'Name der Quelle in Variable schreiben
With Workbooks.Open(vntZuOeffnendeDatei, 0, True)
Quelle = .Name
End With

'Suchen
With ThisWorkbook.Worksheets("Ziel")

For Each suchzelle In .Range("A5:A30")
If suchzelle.Value = Workbooks(Quelle).Worksheets("Quelle").Range("A4").Value Then
'Nachfrage
textalt = .Cells(suchzelle.Row, 1).Value & "|" 'Spalte A und Texttrennzeichen
textalt = textalt & .Cells(suchzelle.Row, 10).Value & "|" 'Spalte J
textalt = textalt & .Cells(suchzelle.Row, 11).Value & "|" 'Spalte K
textneu = textneu & Workbooks(Quelle).Worksheets("Quelle").Range("A4").Value & "|"
textneu = textneu & Workbooks(Quelle).Worksheets("Quelle").Range("J4").Value & "|"
textneu = textneu & Workbooks(Quelle).Worksheets("Quelle").Range("K4").Value & "|"

'Spalten AK bis AP
For sp = 37 To 42
textalt = textalt & .Cells(suchzelle.Row, sp).Value
textneu = textneu & Workbooks(Quelle).Worksheets("Quelle").Cells(4, sp).Value & "|"
If sp < 42 Then
textalt = textalt & "|"
textneu = textneu & "|"
End If
Next sp

rueckgabe = MsgBox(textalt & vbLf & "ersetzen durch" & vbLf & textneu, 36, "Soll der Text überschrieben werden?")

If rueckgabe = vbYes Then
'Quelledaten kopieren
Workbooks(Quelle).Worksheets("Quelle").Range("A4").EntireRow.Copy
'und einfügen
.Cells(suchzelle.Row, 1).PasteSpecial Paste:=xlPasteValues 'nur Werte einfügen
'Auswahl aufheben
Application.CutCopyMode = False
'Quelldatei wieder schließen
Workbooks(Quelle).Close (False)
gefunden = True
Exit For
Else
'Quelldatei wieder schließen
Workbooks(Quelle).Close (False)
Exit Sub
End If
End If
Next
End With

ThisWorkbook.ActiveSheet.Cells(ActiveCell.Row, 1).Select

Application.ScreenUpdating = False

If gefunden = False Then
MsgBox "Der Begriff wurde nicht gefunden!", 16, "Fehler"
End If

End Sub

Gruß

M.O.

Answer 7

Könnten wir vielleicht über e-mail kommunizieren M.O.?

Das wäre echt super und ich wäre mega dankbar, denn ich habe gemerkt du hast ein großes Wissen in VBA.

Meine e-mail ist: TimoTam@gmx.de

Merci