Peter B
Gebruiker
- Lid geworden
- 8 feb 2007
- Berichten
- 672
Ik heb mij hier nog eens in vastgebeten en heb een VBA-code gemaakt die m.i. alles precies doet zoals gevraagd. Hij is alleen niet zo kort geworden omdat er diverse uitzonderingen afgehandeld worden (en bovendien ben ik wat minder bedreven in VBA dan sommige van mijn collega's ...). M.b.v. deze code wordt in kolom C op Blad2 de vertaling geplaatst. Wel moet op het toe te voegen Blad3 vanaf cel A1 een "tabel" worden gemaakt met de mogelijke maten onder elkaar, zoals bv. mm, cm
Code:
Option Explicit
Sub Peter()
Dim aIndex As Variant, aProd As Variant, aMaat As Variant, aTranslate As Variant
Dim i As Long, j As Long, iIndex As Long, iProd As Long, iMaat As Long, iMin As Long, iMax As Long, iNum As Long
Dim sProd As String, sMaat As String, sChar As String
aIndex = Blad1.Cells(1).CurrentRegion
aProd = Blad2.Cells(1).CurrentRegion
aMaat = Blad3.Cells(1).CurrentRegion
ReDim aTranslate(1 To UBound(aProd, 1))
For iProd = 2 To UBound(aProd, 1)
iMin = 0
iMax = 0
sMaat = ""
sProd = aProd(iProd, 1)
For i = 1 To Len(sProd)
sChar = Mid(sProd, i, 1)
If IsNumeric(sChar) Then
iMin = i
Exit For
End If
Next i
For i = Len(sProd) To 1 Step -1
sChar = Mid(sProd, i, 1)
If IsNumeric(sChar) Then
iMax = i + 1
Exit For
End If
Next i
If iMin > 0 Then
iNum = Len(Mid(sProd, iMax, Len(sProd))) - Len(Replace(sProd, " ", "", iMax, , vbTextCompare))
sMaat = Mid(sProd, iMin, iMax - iMin)
For i = 1 To UBound(aMaat, 1)
If InStr(iMax, sProd, aMaat(i, 1), vbTextCompare) > 0 Then
If iMax = InStr(iMax, sProd, aMaat(i, 1), vbTextCompare) Then
sMaat = sMaat & aMaat(i, 1)
Else
sMaat = sMaat & " " & aMaat(i, 1)
iNum = iNum - 1
End If
End If
Next i
sProd = Replace(sProd, sMaat & " ", "", , , vbTextCompare)
sProd = Replace(sProd, " " & sMaat, "", , , vbTextCompare)
End If
For i = 1 To UBound(aIndex, 1)
If sProd = aIndex(i, 1) Then
aTranslate(iProd) = aIndex(i, 2)
If Len(sMaat) > 0 Then
If iNum = 0 Then
aTranslate(iProd) = aTranslate(iProd) & " " & sMaat
Else
For j = Len(aTranslate(iProd)) To 1 Step -1
If Mid(aTranslate(iProd), j, 1) = " " Then
iNum = iNum - 1
If iNum = 0 Then
Exit For
End If
End If
Next j
aTranslate(iProd) = Left(aTranslate(iProd), j) & " " & sMaat & " " & Right(aTranslate(iProd), Len(aTranslate(iProd)) - j)
End If
End If
Exit For
End If
Next i
Next iProd
Blad2.Range("C1:C" & UBound(aTranslate)) = Application.Transpose(aTranslate)
End Sub
