Nummern per Makro in Liste einordnen

Hi!
Vor einiger Zeit hab ich mit viel Hilfe aus diesem Forum ein Makro gebastelt, das Nummern aus einer Liste automatisch in bestimmte Zellen auf einem anderen Tabellenblatt einordnet. Hier der Archiv-Beitrag: https://www.herber.de/forum/archiv/804to808/t807118.htm#807118 . Es geht dabei um eine Liste von Zeichnungs- und Stücklistennummern, in die neue Nummern automatisch importiert werden sollen. Dabei stehen in den Spalten die Baugrößen einer Maschine "ESV", in den Zeilen stehen die Beschreibungstexte der Zeichnungen bzw. Stücklisten. Das Makro sucht die passende Baugröße und den passenden Beschreibungstext und ordnet die Zeichnungsnummmer (beginnt immer mit 200...) und die Stücklistennummer (beginnt immer mit 300...) in die richtigen Zellen ein. So weit klappt das prima, siehe https://www.herber.de/bbs/user/43574.xls .
Nun haben wir aber eine analoge Liste für eine andere Maschine "HR", wo auch dieses Makro zum Einsatz kommen soll.
Problem: Die Größenbezeichnung ist bei dieser Maschine anders, sie besteht aus zwei Zahlen mit einem Schrägstrich dazwischen, z.B. 26/32, also kein rein numerischer Wert mehr. Deswegen gibt es in diesem Teil des Codes ein Problem:
Spalte = WorksheetFunction.Match(CInt(Left(Sheets("import. Nummern").Cells(i, 4).Value, 3)), Sheets("Gesamtliste").Rows(3), 0)
d.h. Excel findet die passende Spalte nicht.
Hier die Datei für die Maschine "HR": https://www.herber.de/bbs/user/44075.xls
Leider weiß ich an dieser Stelle mangels VBA-Kenntnissen nicht weiter. Bin für jede Hilfe dankbar!!
Gruß Matthias

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim SuchText() As String Dim SpaltenText() As String Dim Zelle As Range SuchText = Split("16/-", "/") For Each Zelle In Sheets("Gesamtliste").Range("C3:AX3") SpaltenText = Split(Zelle.Value, "/") If (SpaltenText(0) = SuchText(0) Or SuchText(0) = "-") And (SpaltenText(1) = SuchText(1) Or _ SuchText(1) = "-") Then MsgBox "Suchtext : " & SuchText(0) & "/" & SuchText(1) & Chr(10) & "Spaltentext: " & _ Zelle.Value & Chr(10) & Chr(10) & "Werte einfügen in Spalte " & Zelle.Address Else MsgBox "Suchtext : " & SuchText(0) & "/" & SuchText(1) & Chr(10) & "Spaltentext: " & _ Zelle.Value & Chr(10) & Chr(10) & "Werte nicht einfügen in Spalte " & Zelle.Address End If Next End Sub

Hallo Mathias,
in deiner Beispieldatei war keine Prüfung auf vorhandenen Einträge vorhanden. Ich hab eine Prüfung vor dem Eintragen eingefügt und in der Importliste gibt es einen entsprechenden Eintrag.
Bei leerer Baugröße werden die Dok- und Seriennummer jetzt bei allen Baugrößen eingetragen.
Dazu bitte den Code für Case 1 wie folgt anpassen.
Gruß
Franz


Case 1 ' in Gesamtliste einmal gefunden
'#### Neu Anfang 20070715
'Prüfen ob Einträge vorhanden
With wksGesamt
For Each Zelle In .Range("Tab_Baugröße")
If Not IsEmpty(.Cells(Reihe, Zelle.Column)) Then
wksNrn.Cells(i, 8) = "nein, Einträge schon vorhanden"
GoTo weiter01
End If
Next
End With
'Nummern eintragen
With wksNrn
Suchtext(0) = .Cells(i, 4) 'Baugröße aus Importliste
If InStr(1, Suchtext(0), "/") > 0 Then
Suchtext(1) = Left(.Cells(i, 4), InStr(1, .Cells(i, 4), "/") - 1) 'Linker Teil Baugröß _
e
Suchtext(2) = Mid(.Cells(i, 4), InStr(1, .Cells(i, 4), "/") + 1) 'Rechter Teil Baugröß _
e
End If
End With
With wksGesamt
ForEnde = False
For Each Zelle In .Range("Tab_Baugröße")
If (Zelle.Column - .Range("Tab_Baugröße").Column) Mod 2 = 0 Then 'nur jede 2. Spalte  _
prüfen
Eintragen = False
If Zelle.Value = Suchtext(0) Then
Eintragen = True
ForEnde = True 'Bei eaxakter Übereinstimmung der Baugröße Schleife beenden
ElseIf Suchtext(0) = "" Then
Eintragen = True
ElseIf Suchtext(1) = "-" _
And Suchtext(2) = Mid(Zelle.Value, InStr(1, Zelle.Value, "/") + 1) Then
Eintragen = True
ElseIf Suchtext(1) = Left(Zelle.Value, InStr(1, Zelle.Value, "/") - 1) _
And Suchtext(2) = "-" Then
Eintragen = True
End If
If Eintragen = True Then
.Cells(Reihe, Zelle.Column) = wksNrn.Cells(i, 1)
.Cells(Reihe, Zelle.Column + 1) = wksNrn.Cells(i, 2)
wksNrn.Cells(i, 8) = "ja"
End If
If ForEnde = True Then Exit For
End If
Next Zelle
End With
'#### Neu ende 20070715
Case Else

End Select weiter01: Next i 'Auswertemeldung erzeugen Dim AnzJa As Integer, AnzNicht As Integer, AnzMehrfach As Integer, AnzVorhand As Integer With wksNrn For Zeile = 2 To lZ If InStr(1, .Cells(Zeile, 8).Value, "ja") > 0 Then AnzJa = AnzJa + 1 If InStr(1, .Cells(Zeile, 8).Value, "nicht gefunden") > 0 Then AnzNicht = AnzNicht + 1 If InStr(1, .Cells(Zeile, 8).Value, "mal vorkommt") > 0 Then AnzMehrfach = AnzMehrfach + 1 If InStr(1, .Cells(Zeile, 8).Value, "schon vorhanden") > 0 Then AnzVorhand = AnzVorhand + 1 Next End With Inhalt = "Erfolgreich übertragene Nummern: " & AnzJa & vbLf Inhalt = Inhalt & "Nicht übertragen, da nicht gefunden: " & AnzNicht & vbLf Inhalt = Inhalt & "Nicht übertragen, da mehrfach vorkommend: " & AnzMehrfach & vbLf Inhalt = Inhalt & "Nicht übertragen, da Einträge vorhanden: " & AnzVorhand & vbLf MsgBox Prompt:=Inhalt, Buttons:=vbOKOnly, Title:="Statistik Nummernimport" End Sub

Beliebteste Forumthreads (12 Monate)

Nummern per Makro in Liste einordnen

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread