Option Explicit
Sub drv()
MsgBox BreakOutAll("Green Hoodie: 10 Black Hoodie: -", Worksheets("Data").Columns(2), Worksheets("Data").Columns(1))
MsgBox BreakOutAll("Green Hoodie: 10pcs Black Hoodie: -", Worksheets("Data").Columns(2), Worksheets("Data").Columns(1))
MsgBox BreakOutAll("Phone: 51-83-9498756, 5583772359 Fax: 61-88-4932516", Worksheets("Data").Columns(3))
MsgBox BreakOutAll("Phone: 51-6785239556 Fax: 31-13-45225335 Mobile: -", Worksheets("Data").Columns(3))
MsgBox BreakOutAll("Contact Person: James Anderson Designation: Proprietor", Worksheets("Data").Columns(4))
MsgBox BreakOutAll("Contact Person: Gordan, David Designation: Seller Things", Worksheets("Data").Columns(4))
MsgBox BreakOutAll("Contact Person: David Cameron Miller Designation: Vice President", Worksheets("Data").Columns(4))
End Sub
'
Function BreakOutAll(s As String, KeyWords As Range, Optional Exceptions As Range = Nothing) As String
Dim i As Long, nStart As Long, j As Long
Dim s1 As String, s2 As String
Dim aOut() As String
Dim r1 As Range, x1 As Range
Dim v As Variant, v1 As Variant
Application.Volatile
Set r1 = KeyWords.Columns(1)
Set r1 = r1.Cells(1, 1)
Set r1 = Range(r1, r1.End(xlDown))
If Exceptions Is Nothing Then
Set x1 = Nothing
Else
Set x1 = Exceptions.Columns(1)
Set x1 = x1.Cells(1, 1)
Set x1 = Range(x1, x1.End(xlDown))
If x1.Rows.Count = x1.Parent.Rows.Count Then Set x1 = Nothing
End If
ReDim aOut(1 To r1.Rows.Count, 1 To 2)
'store key words, replacing space with chr(3)
For i = LBound(aOut, 1) To UBound(aOut, 1)
aOut(i, 1) = r1.Cells(i, 1).Value
aOut(i, 1) = Replace(aOut(i, 1), " ", Chr(3))
aOut(i, 2) = "N/A"
Next I
'get rid of multiple spaces
s1 = s
Do While InStr(s1, " ") > 0
s1 = Replace(s1, " ", " ")
s1 = Trim(s1)
Loop
'handle multiple data in single keyword (e.g. Phone: 999888777, 111222333) to keep together
s1 = Replace(s1, ", ", Chr(1))
'go through list of all possible keywords and put Chr(2) in front if space
For i = LBound(aOut, 1) To UBound(aOut, 1)
nStart = InStr(s1, " " & aOut(i, 1))
'if keyword is there, ...
If nStart > 0 Then
Mid(s1, nStart, 1) = Chr(2)
End If
Next I
'make " " = Chr(3)
s1 = Replace(s1, " ", Chr(3))
'Original where a _ represents a space
'Contact_Person:_Gordan,_David_Designation:_Seller_Things
'Replaced where 1=comma+space, 2=space+keyfield, 3=space
'Contact3Person:3Gordan1David2Designation:3Seller3Things
' 1 2 3 4 5
'1234567890123456789012345678901234567890123456789012345
v = Split(s1, Chr(2))
'v(0)
'Contact3Person:3Gordan1David
'v(1)
'Designation:3Seller3Things
For j = LBound(v) To UBound(v)
v1 = Split(v(j), ":" & Chr(3))
'v1(0)
'Contact3Person
'v1(1)
'Gordan1David
'go through list of all possible keywords
For i = LBound(aOut, 1) To UBound(aOut, 1)
If UCase(aOut(i, 1)) = UCase(v1(0)) Then
aOut(i, 2) = v1(1)
'if it's a dash, make N/A again
If aOut(i, 2) = "-" Then aOut(i, 2) = "N/A"
End If
Next I
Next j
'if ther are Exceptions, replace exception list in all data
If Not x1 Is Nothing Then
For i = LBound(aOut, 1) To UBound(aOut, 1)
If aOut(i, 2) <> "N/A" Then
If Not IsNumeric(aOut(i, 2)) Then
For j = 1 To x1.Rows.Count
aOut(i, 2) = Replace(aOut(i, 2), x1.Cells(i, 1), vbNullString, 1, -1, vbTextCompare)
Next j
End If
End If
Next I
End If
'fix strings by removing markers
For i = LBound(aOut, 1) To UBound(aOut, 1)
aOut(i, 1) = Replace(aOut(i, 1), Chr(3), " ")
aOut(i, 1) = Replace(aOut(i, 1), Chr(1), ", ")
aOut(i, 2) = Replace(aOut(i, 2), Chr(3), " ")
aOut(i, 2) = Replace(aOut(i, 2), Chr(1), ", ")
Next i
'build the string
s1 = vbNullString
For i = LBound(aOut, 1) To UBound(aOut, 1)
s1 = s1 & aOut(i, 1) & ": " & aOut(i, 2) & IIf(i < UBound(aOut, 1), " ", vbNullString)
Next I
'put back the ", "
BreakOutAll = Trim(Replace(s1, Chr(1), ", "))
End Function
Reply With Quote
Originally Posted by New_Here
you see my records always vary along these lines...which means its always a little bit of adjustment here and there...
: Hoodies...
for past few weeks now...
