Option Explicit
Const msInputSheet As String = "Sheet1"
Const msMyDataCol As String = "A"
Const msCustCol As String = "B"
Const msResultCol As String = "C"
Sub CorrectData()
Dim iSplitPtr As Integer
Dim lRow1 As Long, lRow2 As Long, lRowEnd As Long, lPtr As Long
Dim rCur As Range
Dim sFirstAddr As String
Dim sCur As String, saSplit() As String
Dim vaData() As Variant
Dim wsInput As Worksheet
Set wsInput = Sheets(msInputSheet)
lPtr = 0
With wsInput.Columns(msMyDataCol)
Set rCur = .Find(what:=",", LookIn:=xlValues, lookat:=xlPart)
If Not rCur Is Nothing Then
sFirstAddr = rCur.Address
Do
sCur = rCur.Value
saSplit = Split(sCur, ",")
rCur.Value = saSplit(0) & saSplit(1)
For iSplitPtr = 2 To UBound(saSplit)
lPtr = lPtr + 1
ReDim Preserve vaData(1 To 1, 1 To lPtr)
vaData(1, lPtr) = saSplit(0) & saSplit(iSplitPtr)
Next iSplitPtr
Set rCur = .FindNext(rCur)
If rCur Is Nothing Then Exit Do
Loop While rCur.Address <> sFirstAddr
End If
End With
If lPtr > 0 Then
lRow1 = wsInput.Cells(Rows.Count, msMyDataCol).End(xlUp).Row + 1
lRow2 = lRow1 + lPtr - 1
wsInput.Range(msMyDataCol & lRow1 & ":" & msMyDataCol & lRow2).Value = WorksheetFunction.Transpose(vaData)
End If
End Sub
Sub MatchData()
Dim iPtr As Integer
Dim lRow As Long, lRowEnd As Long, lResultRow As Long
Dim objCustDictionary As Object
Dim rCur As Range
Dim sCur As String, sCurSeries As String, sCurKey As String, sCurSplit() As String
Dim sRange As String
Dim wsInput As Worksheet
Set wsInput = Sheets(msInputSheet)
wsInput.Range(msResultCol & "2:" & msResultCol & wsInput.UsedRange.Rows.Count).ClearContents
Set objCustDictionary = Nothing
Set objCustDictionary = CreateObject("Scripting.Dictionary")
lRowEnd = wsInput.Cells(Rows.Count, msMyDataCol).End(xlUp).Row
For Each rCur In wsInput.Range(msMyDataCol & "2:" & Cells(lRowEnd, msMyDataCol).Address)
sCur = CStr(rCur.Value)
If sCur <> "" Then
sCurSplit = Split("-" & sCur, "-")
End If
iPtr = UBound(sCurSplit)
If LCase$(sCurSplit(iPtr)) = "series" Then
ReDim Preserve sCurSplit(0 To iPtr - 1)
sCurSeries = Mid$(Join(sCurSplit, "-"), 2)
On Error Resume Next
objCustDictionary.Add key:=sCurSeries, Item:="XXX"
On Error GoTo 0
End If
Next rCur
lRowEnd = wsInput.Cells(Rows.Count, msCustCol).End(xlUp).Row
For Each rCur In wsInput.Range(msCustCol & "2:" & Cells(lRowEnd, msCustCol).Address)
sCur = CStr(rCur.Value)
lRow = 0
On Error Resume Next
lRow = WorksheetFunction.Match(sCur, wsInput.Columns(msMyDataCol), 0)
On Error GoTo 0
If lRow = 0 Then
sCurSplit = Split("-" & sCur, "-")
iPtr = UBound(sCurSplit)
ReDim Preserve sCurSplit(0 To iPtr - 1)
sCurKey = Mid$(Join(sCurSplit, "-"), 2)
If objCustDictionary.exists(sCurKey) Then wsInput.Range(msResultCol & rCur.Row).Value = sCurKey & "-SERIES"
Else
wsInput.Range(msResultCol & rCur.Row).Value = sCur
End If
Next rCur
On Error Resume Next
objCustDictionary.RemoveAll
Set objCustDictionary = Nothing
End Sub
