Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
644to648
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
644to648
644to648
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Ähnliche Nummern aus 2 Tabellen zusammenführen

Ähnliche Nummern aus 2 Tabellen zusammenführen
01.08.2005 08:51:39
Tobias
Hallo zusammen,
ich habe 2 Tabellen mit Artikeln. Für viele Artikel aus der 1. Tabelle existiert ein ähnlicher Artikel in der 2. Tabelle. Dieser unterscheidet sich nur in einem Zeichen der letzten beiden oder letzten 3 Stellen, der Rest ist gleich.
(siehe Beispieltabelle)
https://www.herber.de/bbs/user/25173.xls
Ich möchte nun per VBA Schritt für Schritt die Artikelnummern aus der 1. Tabelle durchgehen. Wenn ein ähnlicher Artikel in der 2. Tabelle gefunden wurde soll die ganze Zeile direkt unter den ähnlichen Artikel aus der 1. Tabelle geschrieben werden.
Kann mir jemand weiterhelfen?
Danke im voraus und Gruß,
Tobias

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Ähnliche Nummern aus 2 Tabellen zusammenführen
01.08.2005 09:22:58
Unbekannter
Ist die Bezeichnung bei den gleichen Artikeln gleich oder geht nur die Nummer ?
AW: Ähnliche Nummern aus 2 Tabellen zusammenführen
01.08.2005 09:50:11
Tobias
Die Bezeichnungen sind nicht gleich. Nur der vordere Teil der Artikelnummer ist gleich.
Gruß,
Tobias
Makro: 1. Versuch
01.08.2005 10:28:52
Matthias5
Hallo Tobias,
mal sehen, ob ich das richtig verstanden habe:


      
Sub abgleich()
Columns(1).Insert
For i = 2 To[b65536].End(xlUp).Row
Range("A" & i) = WorksheetFunction.Replace(Range("B" & i), 4, 1, "")
Next
For j = Sheets(2).Range("A65536").End(xlUp).Row To 1 Step -1
With Range("A:A")
    
Set c = .Find(WorksheetFunction.Replace(Sheets(2).Range("A" & j), 4, 1, ""), LookIn:=xlValues)
    
If Not c Is Nothing Then
        firstRow = c.Row
        
Do
            Sheets(2).Range("A" & j & ":C" & j).Copy
            Range("B" & firstRow + 1).Insert
            
Set c = .FindNext(c)
        
Loop While c.Row <> firstRow
    
End If
End With
Next
Columns(1).Delete
End Sub 


Gruß,
Matthias
Anzeige
Fertig
01.08.2005 11:07:22
Unbekannter
Das Ding ist alles andere als schön geschrieben,aber es geht,ich werde es (wenn ich zeit habe) noch verbessern also schau gegen Mittag(ca 14:00) nochmal rein.

Sub gleich()
Dim e
Dim d
Dim a
Dim b
For a = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For b = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Mid(Sheets(1).Range("a" & a).Value, 5) = Mid(Sheets(2).Range("a" & b).Value, 5) Then
Sheets(2).Rows(b).Copy
Sheets(1).Rows(a + 1).Insert
End If
Next b
Next a
For e = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 10
For d = 1 To Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 10
If Sheets(1).Range("a" & d).Value = Sheets(1).Range("a" & d + 1).Value Then
Rows(d + 1).Delete
End If
Next d
Next e
End Sub

Anzeige
AW: Makro: 1. Versuch
01.08.2005 11:18:46
Tobias
Wow, das ging aber schnell! Vielen Dank!!!
Leider habe ich das Beispiel schlecht gewählt, denn manchmal haben die Artikelnummern mehr Zahlen links vom Buchstaben. Könnte man das Makro so umstellen, daß es auch für diese Artikelnummer funktioniert?
Danke und Gruß,
Tobias
Welches ging Un1 oder Matt ? o.w.t
01.08.2005 11:27:13
Unbekannter
AW: Welches ging Un1 oder Matt ? o.w.t
01.08.2005 11:33:44
Tobias
Das Makro von Matthias meinte ich zuerst.
Von "Unbekannter Nummer Eins" teste ich gerade. Funktioniert ebenfalls wunderbar im Beispiel. Vielen Dank erstmal!
Leider habe ich leider das gleiche Problem, falls die Artikelnummer links vom Buchstaben länger ist.
Gruß,
Tobias
AW: Welches ging Un1 oder Matt ? o.w.t
01.08.2005 11:36:52
Unbekannter
Ich will Matthias 5 seine Arbeit nicht schlecht machen aber wenn man es zwei mal ausführt kommts böse erwachen(zumindestens bei mir).
Anzeige
Nachbesserung
01.08.2005 11:41:08
zupomiwo
Hallo Tobias,
dann versuch doch mal die 2. Version:


      
Sub abgleich()
Dim i As Long, j As Long, k As Integer, l As Integer, c As Long, firstrow As Long
Columns(1).Insert
For i = 2 To[b65536].End(xlUp).Row
    
For k = 1 To Len(Range("B" & i))
        
If Not IsNumeric(Mid(Range("B" & i), k, 1)) Then
            
Exit For
        
End If
    
Next k
Range("A" & i) = WorksheetFunction.Replace(Range("B" & i), k, 1, "x")
Next i
For j = Sheets(2).Range("A65536").End(xlUp).Row To 1 Step -1
With Range("A:A")
    
For l = 1 To Len(Sheets(2).Range("A" & j))
        
If Not IsNumeric(Mid(Sheets(2).Range("A" & j), l, 1)) Then
            
Exit For
        
End If
    
Next l
    
Set c = .Find(WorksheetFunction.Replace(Sheets(2).Range("A" & j), l, 1, "x"), LookIn:=xlValues)
    
If Not c Is Nothing Then
        firstrow = c.Row
        
Do
            Rows(firstrow + 1).Insert
            Sheets(2).Range("A" & j & ":C" & j).Copy Range("B" & firstrow + 1)
            
Set c = .FindNext(c)
        
Loop While c.Row <> firstrow
    
End If
End With
Next j
Columns(1).Delete
End Sub 


Gruß,
Matthias
Anzeige
Sorry, kleiner Fehler...
01.08.2005 11:45:15
Matthias5
sorry, so:


      
Sub abgleich()
Dim i As Long, j As Long, k As Integer, l As Integer, firstrow As Long
Columns(1).Insert
For i = 2 To[b65536].End(xlUp).Row
    
For k = 1 To Len(Range("B" & i))
        
If Not IsNumeric(Mid(Range("B" & i), k, 1)) Then
            
Exit For
        
End If
    
Next k
Range("A" & i) = WorksheetFunction.Replace(Range("B" & i), k, 1, "x")
Next i
For j = Sheets(2).Range("A65536").End(xlUp).Row To 1 Step -1
With Range("A:A")
    
For l = 1 To Len(Sheets(2).Range("A" & j))
        
If Not IsNumeric(Mid(Sheets(2).Range("A" & j), l, 1)) Then
            
Exit For
        
End If
    
Next l
    
Set c = .Find(WorksheetFunction.Replace(Sheets(2).Range("A" & j), l, 1, "x"), LookIn:=xlValues)
    
If Not c Is Nothing Then
        firstrow = c.Row
        
Do
            Rows(firstrow + 1).Insert
            Sheets(2).Range("A" & j & ":C" & j).Copy Range("B" & firstrow + 1)
            
Set c = .FindNext(c)
        
Loop While c.Row <> firstrow
    
End If
End With
Next j
Columns(1).Delete
End Sub 


Anzeige
@Tobias
01.08.2005 11:58:42
Unbekannter
Nein, die Nummer Rechts von dem Buchstaben kann ewig lang sein, geht trotzdem.
bsp:
101N7005645
AW: @UN1
01.08.2005 12:04:55
Matthias5
Hi,
aber Tobias hatte doch geschrieben: ...denn manchmal haben die Artikelnummern mehr Zahlen links vom Buchstaben.
Gruß,
Matthias
gut, mein fehler,sorry o.w.t
01.08.2005 12:11:04
Unbekannter
AW: Vielen Dank für Eure Hilfe!!!
01.08.2005 12:47:08
Tobias
Danke!

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige