Zahl aufteilen u. über die Teilzahlen suchen

Guten Tag :)
Ich habe ein Problem und benötige Hilfe.
Der Link zur Beispieldatei: https://www.herber.de/bbs/user/114708.xlsm
In Spalte B stehen 9-stellige Nummern, die in einer anderen Excel Liste über dynamische Dropdown-Listen und SVerweis-Kombinationen anhand analoger, in den Spalten I bis P stehenden zweispaltigen Tabellen erzeugt wurden.
Die Nummern setzen sich zusammen aus Ebene1 (Zwei Ziffern), Ebene2 (Drei Ziffern) und Ebene 3 (Vier Ziffern).
Dabei steht jede Nummer für einen gewissen Begriff
z.B. : 030230210
Ebene1: 03 entspricht Produktion
Ebene2: 023 entspricht Verpacken
Ebene3: 0210 entspricht Verpackungsgüte
Die 9-stelligen Nummern sollen nun über VBA und eine Schleife wieder aufgeschlüsselt werden und die hinter den Zahlencodes steckenden Begriffe in die Spalten C bis E geschrieben werden.
Spalte C = Ebene1
Spalte D = Ebene2
Spalte E = Ebene3
P.S. Variablendeklarationen habe ich bewusst weg gelassen, da ich denke, dass das Problem teilweise mit dieser zusammenhängt!
Die Lösung muss über VBA erfolgen, da diese Prozedur in ein größeres Programm integriert werden soll.
Hier mein Code:

Sub Trennen()
'Letzte Zeile der Spalte B (= 9-stellige Nummern)
LZ_SpalteB = Tabelle1.Cells(Rows.Count, 2).End(xlUp).Row
LZ_E1 = Tabelle1.Cells(Rows.Count, 10).End(xlUp).Row   	'Letzte Zeile Tabelle Ebene 1
LZ_E2 = Tabelle1.Cells(Rows.Count, 13).End(xlUp).Row 	'Letzte Zeile Tabelle Ebene 2
LZ_E3 = Tabelle1.Cells(Rows.Count, 16).End(xlUp).Row   	'Letzte Zeile Tabelle Ebene 3
arr1 = Tabelle1.Range("J3:J" & LZ_E1)                	'Suchmatrix Ebene 1
arr2 = Tabelle1.Range("M2:M" & LZ_E2)                 	'Suchmatrix Ebene 2
arr3 = Tabelle1.Range("P2:P" & LZ_E3)                 	'Suchmatrix Ebene 3
For i = 1 To LZ_SpalteB
Zelle = Tabelle1.Range("B" & i)    'Zelle mit Ursachencode
E1 = Left$(Zelle, 2)               'Split: Ebene 1
E2 = Mid$(Zelle, 3, 3)             'Split: Ebene 2
E3 = Right$(Zelle, 4)              'Split: Ebene 3
MsgBox (E1 & "     " & E2 & "     " & E3 & "   Zeile:  & Zeile")
'Zeile = Application.Match(W1, arr1, 0)
'Cells(1, 3) = WorksheetFunction.VLookup(W1, [H3:I4], 2, False)
Next
End Sub

Die Aufteilung der Nummer in die Teilnummern klappt schon. Zur Überprüfung lasse ich diese über die Msgbox ausgeben.
Im zweiten Schritt schlagen meine zahlreichen Lösungsversuche über VLookup und Application.match andauernd fehl.
Hat jemand eine Lösung parat?
Vielen Dank im Voraus.
LG

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

hALLO;
Versuch mal so:

Option Explicit
Sub machs()
    Dim Bereich As Variant
    Dim myDic As Object
    Dim LZ_E1, LZ_E2, LZ_E3
    Dim arr1, arr2, arr3
    Dim L As Long
    Bereich = Tabelle1.Range("B1").CurrentRegion.Resize(, 4)
    Set myDic = CreateObject("Scripting.Dictionary")
    LZ_E1 = Tabelle1.Cells(Rows.Count, 10).End(xlUp).Row 'Letzte Zeile Tabelle Ebene 1
    LZ_E2 = Tabelle1.Cells(Rows.Count, 13).End(xlUp).Row 'Letzte Zeile Tabelle Ebene 2
    LZ_E3 = Tabelle1.Cells(Rows.Count, 16).End(xlUp).Row 'Letzte Zeile Tabelle Ebene 3
    arr1 = Tabelle1.Range("I3:J" & LZ_E1) 'Suchmatrix Ebene 1
    arr2 = Tabelle1.Range("L2:M" & LZ_E2) 'Suchmatrix Ebene 2
    arr3 = Tabelle1.Range("O2:P" & LZ_E3)
    For L = 1 To UBound(arr1)
        myDic(arr1(L, 2)) = arr1(L, 1)
    Next
    For L = 1 To UBound(arr2)
        myDic(arr2(L, 2)) = arr2(L, 1)
    Next
    For L = 1 To UBound(arr3)
        myDic(arr3(L, 2)) = arr3(L, 1)
    Next
    For L = 1 To UBound(Bereich)
        Bereich(L, 2) = myDic(Left(Bereich(L, 1), 2))
        Bereich(L, 3) = myDic(Mid(Bereich(L, 1), 3, 3))
        Bereich(L, 4) = myDic(Mid(Bereich(L, 1), 6, 4))
    Next
    Tabelle1.Range("B1").CurrentRegion.Resize(, 4) = Bereich
End Sub

ransi

Public Sub Ebenen() Dim loLetzte As Long Dim i As Long With Worksheets("Tabelle1") loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row For i = 1 To loLetzte .Cells(i, 3) = WorksheetFunction.VLookup(Left(.Cells(i, 2), 2), .Columns("H:I"), 2, False) .Cells(i, 4) = WorksheetFunction.VLookup(Mid(.Cells(i, 2), 3, 3), .Columns("K:L"), 2, False) .Cells(i, 5) = WorksheetFunction.VLookup(Right(.Cells(i, 2), 4), .Columns("N:O"), 2, False) Next i End With End Sub

Beliebteste Forumthreads (12 Monate)

Zahl aufteilen u. über die Teilzahlen suchen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread