Combined numbers and texts without delimiter- need VBA code to split and perform calculations

[adelkam]

I appreciate if somebody can provide a VBA code to handle this. I lately managed to resolve it using a complicated use of excel functions and arrays, but it seems to be running slow because the worksheet has to recalculate using the 2 processors because the extensive use of arrays.

My excel database sheet contains inventory of products and quantities, each is defined in the form of combined number followed by text without a delimiter. For example 2AWS means Two (2) of AWS.

Each cell of the inventory field may contain up to two products, each product is identified in the above format; but the pair of products are separated with a comma.

The inventory field is occupying from cell $A$2:$A$5000; and is defined as a named range "INV_QTY" with scope within the entire workbook. I need to calculate the total inventory for each product.

Here's an example:

Cell A2: 3GFG, 1AWS
Cell A3: 2NG, 2AWS
Cell A4: 3AWS
Cell A5: 4QLK, 4GFG

etc.


The desired output should be calculated as follows (assume Input will be on Column C & D)

Product - QTY
GFG - 7 (i.e. Cell C2: GFG , Cell D2:7 etc.)
AWS - 6
NG - 2
QLK - 4

I appreciate your help

 

[hippiehacker]

a slightly start would be

Sub data()
Range("A:A").Select
Do
Selection.TextToColumns Destination:=ActiveCell.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Loop Until IsEmpty(ActiveCell.Columns("A:A"))


Dim Bcell As Range
Dim lCount As Long
Dim lastcellB
Dim lastcellA
lastcellB = Range("B" & Rows.Count).End(xlUp).Row
  For lCount = lastcellB To 1 Step -1
  'Start from bottom of range, so we don't skip any rows When we've deleted one
  If Trim(Range("B" & lCount).Value) = "" Then
     Range("B" & lCount).Delete Shift:=xlUp
  Else
  End If
  Next lCount
 lastcellB = Range("B" & Rows.Count).End(xlUp).Row
 lastcellA = Range("A" & Rows.Count).End(xlUp).Row
 
 Range("B1:B" & lastcellB).Copy Destination:=Range("A" & lastcellA + 1)
Range("B:B").Delete

For Each cell In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
 cell.Offset(0, 1).Value = Extract_Number_from_Text(cell.Value)

 
 Next
 
End Sub



Function Extract_Number_from_Text(Phrase As String) As Double
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim Temp As String
Length_of_String = Len(Phrase)
Temp = ""
For Current_Pos = 1 To Length_of_String
If (Mid(Phrase, Current_Pos, 1) = "-") Then
  Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (Mid(Phrase, Current_Pos, 1) = ".") Then
 Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (IsNumeric(Mid(Phrase, Current_Pos, 1))) = True Then
    Temp = Temp & Mid(Phrase, Current_Pos, 1)
 End If
Next Current_Pos
If Len(Temp) = 0 Then
    Extract_Number_from_Text = 0
Else
    Extract_Number_from_Text = CDbl(Temp)
End If
End Function

 

[adelkam]

Thanks hippiehacker! that was a great help !!
I did minor change including another function to return the string part in another cell..

I appreciate if you advised on how to calculate the aggregate sum for the same item and return similar to the desired output in the original question ...

Thanks again for the great help ...The final code is:

Sub data()
Range("A:A").Select


' First Split on comma
Do
Selection.TextToColumns Destination:=ActiveCell.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Loop Until IsEmpty(ActiveCell.Columns("A:A"))




Dim Bcell As Range
Dim lCount As Long
Dim lastcellB
Dim lastcellA
lastcellB = Range("B" & Rows.Count).End(xlUp).Row
  For lCount = lastcellB To 1 Step -1
  'Start from bottom of range, so we don't skip any rows When we've deleted one
  If Trim(Range("B" & lCount).Value) = "" Then
     Range("B" & lCount).Delete Shift:=xlUp
  Else
  End If
  Next lCount
 lastcellB = Range("B" & Rows.Count).End(xlUp).Row
 lastcellA = Range("A" & Rows.Count).End(xlUp).Row
 
 Range("B1:B" & lastcellB).Copy Destination:=Range("A" & lastcellA + 1)
Range("B:B").Delete


For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
 cell.Offset(0, 2).Value = Extract_Number_from_Text(cell.Value)
 
Next
 
For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
 cell.Offset(0, 1).Value = Extract_Text_Part(cell.Value)
 
Next
 
End Sub



Function Extract_Number_from_Text(Phrase As String) As Double
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim Temp As String
Length_of_String = Len(Phrase)
Temp = ""


For Current_Pos = 1 To Length_of_String
If (Mid(Phrase, Current_Pos, 1) = "-") Then
  Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (Mid(Phrase, Current_Pos, 1) = ".") Then
 Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (IsNumeric(Mid(Phrase, Current_Pos, 1))) = True Then
    Temp = Temp & Mid(Phrase, Current_Pos, 1)
        
 End If
Next Current_Pos
If Len(Temp) = 0 Then
    Extract_Number_from_Text = 0
Else
    Extract_Number_from_Text = CDbl(Temp)
End If
End Function


Function Extract_Text_Part(Phrase As String) As String
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim txt As String
Length_of_String = Len(Phrase)


txt = ""
For Current_Pos = 1 To Length_of_String
If (Mid(Phrase, Current_Pos, 1) = "-") Then
  txt = txt & Mid(Phrase, Current_Pos, 1)
End If
If (Mid(Phrase, Current_Pos, 1) = ".") Then
 txt = txt & Mid(Phrase, Current_Pos, 1)
End If
If (IsNumeric(Mid(Phrase, Current_Pos, 1))) = False Then
    txt = txt & Mid(Phrase, Current_Pos, 1)
        
 End If
Next Current_Pos
If Len(txt) = 0 Then
    Extract_Text_Part = ""
Else
    Extract_Text_Part = Trim(CStr(txt))
End If
End Function

 

[hippiehacker]

the final code should be

Sub data()
Range("A:A").Select


' First Split on comma
Do
Selection.TextToColumns Destination:=ActiveCell.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlSingleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Loop Until IsEmpty(ActiveCell.Columns("A:A"))




Dim Bcell As Range
Dim lCount As Long
Dim lastcellB
Dim lastcellA
lastcellB = Range("B" & Rows.Count).End(xlUp).Row
  For lCount = lastcellB To 1 Step -1
  'Start from bottom of range, so we don't skip any rows When we've deleted one
  If Trim(Range("B" & lCount).Value) = "" Then
     Range("B" & lCount).Delete Shift:=xlUp
  Else
  End If
  Next lCount
 lastcellB = Range("B" & Rows.Count).End(xlUp).Row
 lastcellA = Range("A" & Rows.Count).End(xlUp).Row
 
 Range("B1:B" & lastcellB).Copy Destination:=Range("A" & lastcellA + 1)
Range("B:B").Delete


For Each Cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
 Cell.Offset(0, 2).Value = Extract_Number_from_Text(Cell.Value)
 Cell.Offset(0, 1).Value = Extract_Text_Part(Cell.Value)
Next
 
 Range("B2:C" & Range("C" & Rows.Count).End(xlUp).Row).Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
For Each Cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
Do While Cell.Value = Cell.Offset(1, 0).Value
  Cell.Offset(0, 1).Value = Cell.Offset(0, 1).Value + Cell.Offset(1, 1).Value
  Range(Cell.Offset(1, 0), Cell.Offset(1, 1)).Select
  Selection.Delete Shift:=xlUp
Loop
Next
End Sub



Function Extract_Number_from_Text(Phrase As String) As Double
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim Temp As String
Length_of_String = Len(Phrase)
Temp = ""


For Current_Pos = 1 To Length_of_String
If (Mid(Phrase, Current_Pos, 1) = "-") Then
  Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (Mid(Phrase, Current_Pos, 1) = ".") Then
 Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (IsNumeric(Mid(Phrase, Current_Pos, 1))) = True Then
    Temp = Temp & Mid(Phrase, Current_Pos, 1)
        
 End If
Next Current_Pos
If Len(Temp) = 0 Then
    Extract_Number_from_Text = 0
Else
    Extract_Number_from_Text = CDbl(Temp)
End If
End Function


Function Extract_Text_Part(Phrase As String) As String
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim txt As String
Length_of_String = Len(Phrase)


txt = ""
For Current_Pos = 1 To Length_of_String
If (Mid(Phrase, Current_Pos, 1) = "-") Then
  txt = txt & Mid(Phrase, Current_Pos, 1)
End If
If (Mid(Phrase, Current_Pos, 1) = ".") Then
 txt = txt & Mid(Phrase, Current_Pos, 1)
End If
If (IsNumeric(Mid(Phrase, Current_Pos, 1))) = False Then
    txt = txt & Mid(Phrase, Current_Pos, 1)
        
 End If
Next Current_Pos
If Len(txt) = 0 Then
    Extract_Text_Part = ""
Else
    Extract_Text_Part = Trim(CStr(txt))
End If
End Function

 

[adelkam]

Thanks a lot . it works..
Is there any idea to speed it up? it takes about 6 seconds when I try it with 30 records..
I intend to use it with database of few hundreds of records..
Thanks again

 

[hippiehacker]

at the beginning use to speed it up

Sub data()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

for me it took around 6 seconds to process 2000 records

 

[adelkam]

Thanks a lot !!
It was a while since I needed to reuse the code.. I appreciate if I have a little modification to the code above to summarize data differently ...

I need to read the combined data and split for each line .

Here's an example for the input (as above):

Cell A2: 3GFG, 1AWS
Cell A3: 2NG, 2AWS
Cell A4: 3AWS
Cell A5: 4QLK, 4GFG

etc.


The desired output: I have the text in header (with one column as a space in between) and need to extract quantities for each line, under each text as follows:

Headers at: Cell C4: "GFG" , Cell E4: "AWS" , Cell G4: "NG" , Cell I4: "QLK"
Cell C5 : 3 , Cell E5: 1
Cell E6: 2 , Cell G6: 2
Cell E7: 3
Cell C8: 4, Cell I8:4

I appreciate your help .. thanks

 

[Rick Rothstein]

Here's an example for the input (as above):

Cell A2: 3GFG, 1AWS
Cell A3: 2NG, 2AWS
Cell A4: 3AWS
Cell A5: 4QLK, 4GFG

etc.

The desired output: I have the text in header (with one column as a space in between) and need to extract quantities for each line, under each text as follows:

Headers at: Cell C4: "GFG" , Cell E4: "AWS" , Cell G4: "NG" , Cell I4: "QLK"
Cell C5 : 3 , Cell E5: 1
Cell E6: 2 , Cell G6: 2
Cell E7: 3
Cell C8: 4, Cell I8:4

I believe this macro will do what you want...

Sub ProcessData()
  Dim X As Long, Z As Long, DataLastRow As Long, vArr As Variant, NameCell As Range
  Dim CodeAmount As Double, CodeName As String, Codes() As String
  
  Const OutputHeaderRow As Long = 4
  Const ColumnOffsets As Long = 2
  Const DataColumn As String = "A"
  Const DataStartRow As Long = 2
  
  DataLastRow = Cells(Rows.Count, DataColumn).End(xlUp).Row
  vArr = Cells(DataStartRow, DataColumn).Resize(DataLastRow - DataStartRow + 1)
  For X = 1 To UBound(vArr)
    Codes = Split(Replace(vArr(X, 1), " ", ""), ",")
    For Z = 0 To UBound(Codes)
      CodeAmount = Val(Codes(Z))
      CodeName = Replace(Codes(Z), CodeAmount, "")
      Set NameCell = Range(Cells(OutputHeaderRow, "B"), Cells(OutputHeaderRow, _
                           Columns.Count)).Find(CodeName, LookAt:=xlWhole, MatchCase:=False)
      If NameCell Is Nothing Then
        With Cells(OutputHeaderRow, Columns.Count).End(xlToLeft).Offset(, ColumnOffsets)
          .Value = UCase(CodeName)
          .Offset(X).Value = CodeAmount
        End With
      Else
        NameCell.Offset(X) = CodeAmount
      End If
    Next
  Next
End Sub

NOTE: The entire execution of the code is controlled by the four Const statements. I set them to the values you gave in your message, but if you need to rearrange your data, just change their assigned values to match your new setup.