Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.
Sub Sample()
Dim i As Long, j As Long, k As Long, LastRow As Long, r As Long, pos As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim HashArray() As String, StarArray() As String
Dim strTemp As String
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Output").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set ws1 = Sheets("Raw Data")
Set ws2 = Sheets.Add
ws2.Name = "Output"
LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
r = 1
For i = 1 To LastRow
If InStr(1, ws1.Range("B" & i).Value, "#") Or InStr(1, ws1.Range("B" & i).Value, "*") Then
strTemp = ws1.Range("A" & i).Value
ws2.Range("A" & r).Value = ws1.Range("A" & i).Value
HashArray = Split(ws1.Range("B" & i).Value, "#")
For j = 0 To UBound(HashArray) - 1
If InStr(1, HashArray(j), "*") Then
StarArray = Split(HashArray(j), "*")
For k = 0 To UBound(StarArray)
If Left(StarArray(k), 1) = "," Then
ws2.Range("B" & r).Value = Mid(StarArray(k), 3)
Else
ws2.Range("B" & r).Value = StarArray(k)
End If
pos = InStr(1, ws1.Range("B" & i).Value, StarArray(k)) + Len(StarArray(k))
If Mid(ws1.Range("B" & i).Value, pos, 1) = "#" Then
ws2.Range("C" & r).Value = "EXT"
ElseIf Mid(ws1.Range("B" & i).Value, pos, 1) = "*" Then
ws2.Range("C" & r).Value = "INT"
End If
ws2.Range("A" & r).Value = strTemp
r = ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
Next
Else
If Left(HashArray(j), 1) = "," Then
ws2.Range("B" & r).Value = Mid(HashArray(j), 3)
Else
ws2.Range("B" & r).Value = HashArray(j)
End If
pos = InStr(1, ws1.Range("B" & i).Value, HashArray(k)) + Len(HashArray(k))
If Mid(ws1.Range("B" & i).Value, pos, 1) = "#" Then
ws2.Range("C" & r).Value = "EXT"
ElseIf Mid(ws1.Range("B" & i).Value, pos, 1) = "*" Then
ws2.Range("C" & r).Value = "INT"
End If
ws2.Range("A" & r).Value = strTemp
r = ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
End If
Next
End If
r = ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
Next i
End Sub
ERA-EE.xlsm
Sub Sample()
Dim i As Long, j As Long, k As Long, LastRow As Long, r As Long, pos As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim HashArray() As String, StarArray() As String
Dim strTemp As String
Dim rng As Range
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Output").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set ws1 = Sheets("Raw Data")
Set ws2 = Sheets.Add
ws2.Name = "Output"
LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row
r = 1
For i = 1 To LastRow
Set rng = ws1.Range("E" & i & ":AK" & i)
If InStr(1, ws1.Range("C" & i).Value, "#") Then
strTemp = ws1.Range("B" & i).Value
ws2.Range("A" & r).Value = ws1.Range("A" & i).Value
ws2.Range("B" & r).Value = ws1.Range("B" & i).Value
HashArray = Split(ws1.Range("C" & i).Value, "#")
For j = 0 To UBound(HashArray)
If InStr(1, HashArray(j), "*") Then
StarArray = Split(HashArray(j), "*")
For k = 0 To UBound(StarArray)
If Left(StarArray(k), 1) = "," Then
ws2.Range("C" & r).Value = Mid(StarArray(k), 3)
Else
ws2.Range("C" & r).Value = StarArray(k)
End If
pos = InStr(1, ws1.Range("C" & i).Value, StarArray(k)) + Len(StarArray(k))
If Mid(ws1.Range("C" & i).Value, pos, 1) = "#" Then
ws2.Range("D" & r).Value = "EXT"
ElseIf Mid(ws1.Range("C" & i).Value, pos, 1) = "*" Then
ws2.Range("D" & r).Value = "INT"
End If
ws2.Range("B" & r).Value = strTemp
rng.Copy ws2.Range("E" & r & ":AK" & r)
r = ws2.Range("C" & Rows.Count).End(xlUp).Row + 1
Next
Else
If Left(HashArray(j), 1) = "," Then
ws2.Range("C" & r).Value = Mid(HashArray(j), 3)
Else
ws2.Range("C" & r).Value = HashArray(j)
End If
pos = InStr(1, ws1.Range("C" & i).Value, HashArray(j)) + Len(HashArray(j))
If Mid(ws1.Range("C" & i).Value, pos, 1) = "#" Then
ws2.Range("D" & r).Value = "EXT"
ElseIf Mid(ws1.Range("C" & i).Value, pos, 1) = "*" Then
ws2.Range("D" & r).Value = "INT"
End If
ws2.Range("B" & r).Value = strTemp
rng.Copy ws2.Range("E" & r & ":AK" & r)
r = ws2.Range("C" & Rows.Count).End(xlUp).Row + 1
End If
Next
ElseIf InStr(1, ws1.Range("C" & i).Value, "*") Then
strTemp = ws1.Range("B" & i).Value
ws2.Range("A" & r).Value = ws1.Range("A" & i).Value
ws2.Range("B" & r).Value = ws1.Range("B" & i).Value
StarArray = Split(ws1.Range("C" & i).Value, "*")
For k = 0 To UBound(StarArray)
If Len(Trim(StarArray(k))) = 0 Then Exit For
If Left(StarArray(k), 1) = "," Then
ws2.Range("C" & r).Value = Mid(StarArray(k), 3)
Else
ws2.Range("C" & r).Value = StarArray(k)
End If
pos = InStr(1, ws1.Range("C" & i).Value, StarArray(k)) + Len(StarArray(k))
If Mid(ws1.Range("C" & i).Value, pos, 1) = "#" Then
ws2.Range("D" & r).Value = "EXT"
ElseIf Mid(ws1.Range("C" & i).Value, pos, 1) = "*" Then
ws2.Range("D" & r).Value = "INT"
End If
ws2.Range("B" & r).Value = strTemp
rng.Copy ws2.Range("E" & r & ":AK" & r)
r = ws2.Range("C" & Rows.Count).End(xlUp).Row + 1
Next
End If
r = ws2.Range("C" & Rows.Count).End(xlUp).Row + 1
Next i
End Sub
Raw-Data.xls
and only thing i would do is, will add the cleansed data in a new sheet rather than adding new rows inbetween and clean it. Coz, it might cause some disturbance to existing data.
-Bala