Ich bin neu hier und dies ist mein erster Post. Meine noch bescheidenen VBA-Kenntnisse habe ich mir überwiegend in diesem Forum angeeignet.
In Spalte A stehen Artikelnamen. Die Artikelnamen bestehen aus bis zu 9 Bestandteilen, getrennt durch Leerzwichen. Die Reihenfolge dieser Bestandteile kann variiren.
Diese Artikelnamen sollen nun in Ihre Bestandteile aufgeteilt werden. Diese Bestandteile sollen dann zur weiteren Verwendung/Bearbeitung in jeweils bestimmte Spalten C:J eingetragen werden. So soll in Spalte J die Farbe stehen.
Probleme:
- Auch wenn es wahrscheinlich nicht schön gelöst ist von mir, klappt es so weit. Ist aber offenbar sehr fehleranfällig.
- So kommt es in Zeile 6044-6058, z.B. dem Artikelnamen "Mini C K W black" zu einem Konflikt ("Doppeldeutung") Da es sowohl einen Bestandteil "C" aber auch den Bestandteil "Mini C" gibt. Das "C" gehört hier aber nur zu "Mini C".
- Ein Bestandteil, ein String wie "60.80" wird als "60,8" in die Spalte übertragen. Bisher habe ich dies mit einer vorherigen Formatierung der Spalte gelöst.
Eigentlich wollte ich dies rein über Arrays machen und dann das Ergebnis in einem Schwung in die Spalten C:J eintragen. Da muss ich aber noch mehr lernen. Es sind bis zu 20.000 Datensätze mit bis zu 9 Bestandteilen und später sollen in einem weiteren Schritt 2 solche Tabellen abgeglichen werden um neue Datensätze und bereits vorhandene Datensätze zu finden und zu markieren (Eintrag in weiterer Spalte). Das ist der Grund warum ich mich für Arrays entschieden habe.
Der Makro läuft bei mir zwischen 30 und 90 Sekunden.
Ich würde mich sehr über Hilfe und eine Erweiterung meines VBA-Horizontes freuen. Sollte ich was falsch gemacht haben und nicht regelkonform agiert haben, bitte ich vielmals um Entschuldigung und freue mich auf einen entsprechenden Hinweis.
Ich danke Euch vielmals im Voraus!
Mit besten Grüßen
Robert
https://www.herber.de/bbs/user/148833.xlsb
Mein Code:
Option Explicit
Sub Erste_Aufteilung()
' ***** Timer-Funktion START
Dim StartingTime1 As Single
StartingTime1 = Timer
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
Worksheets("Tabelle1").Activate
' ***** Zelladresse, erstes Finden
Dim strAdr01 As String, strAdr02 As String, strAdr03 As String, strAdr04 As String, strAdr05 As String, _
strAdr06 As String, strAdr07 As String, strAdr08 As String
' ***** Zelladresse, nächstes Finden
Dim rngTreffer01 As Range, rngTreffer02 As Range, rngTreffer03 As Range, rngTreffer04 As Range, rngTreffer05 As Range, _
rngTreffer06 As Range, rngTreffer07 As Range, rngTreffer08 As Range
' ***** in A:A zu suchende Werte
Dim VarDat01 As Variant, VarDat02 As Variant, VarDat03 As Variant, VarDat04 As Variant, VarDat05 As Variant, _
VarDat06 As Variant, VarDat07 As Variant, VarDat08 As Variant
' ***** Position im jeweiligen Array
Dim lngZ01 As Long, lngZ02 As Long, lngZ03 As Long, lngZ04 As Long, lngZ05 As Long, _
lngZ06 As Long, lngZ07 As Long, lngZ08 As Long
' ***** ARRAY defginition, Suchbegriffe für Spalten C:J
VarDat01 = Array("black", "white", "graphite", "snow-white", "grey", "black/copper", "black/gold", "black/rose", "black/rose-gold", "black/snow-white", "snow-white/black")
VarDat02 = Array(" PR ", " SOFT ", " SPR ")
VarDat03 = Array(" DALI ", " ON/OFF ", " PUSH-DIM ", " TRIAC ")
VarDat04 = Array(" N ", " NW ", " SN ", " SNW ", " SW ", " W ")
VarDat05 = Array(" F ", " IN ", " K ", " ON ", " T ", " TRC ", " Z ", " ZS ")
VarDat06 = Array(" II ", " L ", " R ", " V ", " X ")
VarDat07 = Array(" 10 ", " 13 ", " 14 ", " 15 ", " 20 ", " 25 ", " 30 ", " 40 ", " 45 ", " 50 ", " 60 ", " 65 ", " 70 ", " 90 ", " 100 ", " 110 ", " 120 ", " 136 ", " 150 ", _
" 160 ", " 240 ", " 250 ", " 300 ", " 136I ", " 136II ", " 160I ", " 160II ", " A ", " B ", " C ", " D ", " E ", " L ", " L11 ", " L111 ", " L21 ", " L31 ", " M ", " R ", " R11 ", " R111 ", " R21 ", " R31 ", " V ", " XL ", " XXL ")
VarDat08 = Array("60.80 ", "Accent ", "Accent RT ", "Ambiente ", "Backlight ", "Backlight+ ", "Beep ", "Beep-Care ", "Box ", "Coro ", "Cubic ", "Cubic-Slim ", "D ", "D-Bay ", "D+ ", "Danse ", _
"Firefly ", "Flask ", "Fusion ", "Fusion RT ", "Grand ", "Hello ", "Illu ", "Luna-Llena ", "Luno ", "Maia ", "Maman R ", "Maxime ", "Maxime R ", "MBox ", "MFusion ", "Mini C ", "Minus ", "Moi ", _
"Moi C ", "Moi R ", "Moonlight ", "Myco ", "Myco-One ", "Ocu ", "Optique ", "Orionis ", "Otel ", "PDX ", "Plus", "Pick-Me ", "Qua+ ", "Qua+ R ", "Ra ", "Ra-Mini ", "Reel ", "Reel+ ", "Slim-Line+ ", _
"Subtil ", "Telescope ", "Thiny-Slim ", "Thiny-Slim RT ", "Thiny-Slim+ ", "Thiny-Snake ", "Tonic ", "Vectris ", "Vectris+ ")
Dim maxRow As Integer
maxRow = Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row
' ***** Code für letzte Spalte J:J
For lngZ01 = LBound(VarDat01) To UBound(VarDat01)
Set rngTreffer01 = Range("A1:A" & maxRow).Find(What:=VarDat01(lngZ01), LookAt:=xlPart)
If Not rngTreffer01 Is Nothing Then
strAdr01 = rngTreffer01.Address
Do
rngTreffer01.Offset(, 9) = VarDat01(lngZ01)
Set rngTreffer01 = Range("A1:A" & maxRow).FindNext(rngTreffer01)
Loop While Not rngTreffer01 Is Nothing And rngTreffer01.Address strAdr01
End If
Next lngZ01
For lngZ02 = LBound(VarDat02) To UBound(VarDat02)
Set rngTreffer02 = Range("A1:A" & maxRow).Find(What:=VarDat02(lngZ02), LookAt:=xlPart)
If Not rngTreffer02 Is Nothing Then
strAdr02 = rngTreffer02.Address
Do
rngTreffer02.Offset(, 8) = VarDat02(lngZ02)
Set rngTreffer02 = Range("A1:A" & maxRow).FindNext(rngTreffer02)
Loop While Not rngTreffer02 Is Nothing And rngTreffer02.Address strAdr02
End If
Next lngZ02
For lngZ03 = LBound(VarDat03) To UBound(VarDat03)
Set rngTreffer03 = Range("A1:A" & maxRow).Find(What:=VarDat03(lngZ03), LookAt:=xlPart)
If Not rngTreffer03 Is Nothing Then
strAdr03 = rngTreffer03.Address
Do
rngTreffer03.Offset(, 7) = VarDat03(lngZ03)
Set rngTreffer03 = Range("A1:A" & maxRow).FindNext(rngTreffer03)
Loop While Not rngTreffer03 Is Nothing And rngTreffer03.Address strAdr03
End If
Next lngZ03
For lngZ04 = LBound(VarDat04) To UBound(VarDat04)
Set rngTreffer04 = Range("A1:A" & maxRow).Find(What:=VarDat04(lngZ04), LookAt:=xlPart)
If Not rngTreffer04 Is Nothing Then
strAdr04 = rngTreffer04.Address
Do
rngTreffer04.Offset(, 6) = VarDat04(lngZ04)
Set rngTreffer04 = Range("A1:A" & maxRow).FindNext(rngTreffer04)
Loop While Not rngTreffer04 Is Nothing And rngTreffer04.Address strAdr04
End If
Next lngZ04
For lngZ05 = LBound(VarDat05) To UBound(VarDat05)
Set rngTreffer05 = Range("A1:A" & maxRow).Find(What:=VarDat05(lngZ05), LookAt:=xlPart)
If Not rngTreffer05 Is Nothing Then
strAdr05 = rngTreffer05.Address
Do
rngTreffer05.Offset(, 5) = VarDat05(lngZ05)
Set rngTreffer05 = Range("A1:A" & maxRow).FindNext(rngTreffer05)
Loop While Not rngTreffer05 Is Nothing And rngTreffer05.Address strAdr05
End If
Next lngZ05
For lngZ06 = LBound(VarDat06) To UBound(VarDat06)
Set rngTreffer06 = Range("A1:A" & maxRow).Find(What:=VarDat06(lngZ06), LookAt:=xlPart)
If Not rngTreffer06 Is Nothing Then
strAdr06 = rngTreffer06.Address
Do
rngTreffer06.Offset(, 4) = VarDat06(lngZ06)
Set rngTreffer06 = Range("A1:A" & maxRow).FindNext(rngTreffer06)
Loop While Not rngTreffer06 Is Nothing And rngTreffer06.Address strAdr06
End If
Next lngZ06
For lngZ07 = LBound(VarDat07) To UBound(VarDat07)
Set rngTreffer07 = Range("A1:A" & maxRow).Find(What:=VarDat07(lngZ07), LookAt:=xlPart)
If Not rngTreffer07 Is Nothing Then
strAdr07 = rngTreffer07.Address
Do
rngTreffer07.Offset(, 3) = VarDat07(lngZ07)
Set rngTreffer07 = Range("A1:A" & maxRow).FindNext(rngTreffer07)
Loop While Not rngTreffer07 Is Nothing And rngTreffer07.Address strAdr07
End If
Next lngZ07
For lngZ08 = LBound(VarDat08) To UBound(VarDat08)
Set rngTreffer08 = Range("A1:A" & maxRow).Find(What:=VarDat08(lngZ08), LookAt:=xlPart)
If Not rngTreffer08 Is Nothing Then
strAdr08 = rngTreffer08.Address
Do
rngTreffer08.Offset(, 2) = VarDat08(lngZ08)
Set rngTreffer08 = Range("A1:A" & maxRow).FindNext(rngTreffer08)
Loop While Not rngTreffer08 Is Nothing And rngTreffer08.Address strAdr08
End If
Next lngZ08
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.Calculation = xlCalculationAutomatic
' ***** Timer-Funktion STOP
Debug.Print "Benötigte Zeit: " & Format((Timer - StartingTime1) / 86400, "hh:mm:ss") & " Minuten."
Debug.Print " "
End Sub