VBA Code to filter a list, then create new list in a new column

[wpaj1025]

Hello,

My goal is to get a final array (list) that is based-on the contents of a description field that is not consistent:

1. Provided file

SKU	Description
4876	1Y Depot + ADP Post Warranty
7598	1Y Depot +SBTY Post Warranty
6247	1Y Onsite + KYD PW (CPN Federate)
3018	PROTECTION 1YR OS 24x7x4 + KYD (RS)
5716	PROTECTION 3Y Onsite + ADP TSS
5723	2Mo Onsite + Priority Support
7270	PROTECTION 3Y Depot + ADP TSS

2. Goal
Extract information from the description field to populate the below table. If the text is not in the description then the field would be blank.

What I have done so far is to Filter the list alphabetically, then create formulas using Left, Mid and Right.
However, due to the size of the file this is time consuming (over 1k rows).

Desired outcome:

SKU	Description	Term (all)	Term Months	Location	Response Time	ADP	KYD	SBTY
4876	1Y Depot + ADP Post Warranty	1y	12			ADP
7598	1Y Depot +SBTY Post Warranty	1y	12					SBTY
6247	1Y Onsite + KYD PW (CPN Federate)	1y	12				KYD
3018	PROTECTION 1YR OS 24x7x4 + KYD (RS)	1y	12	Onsite	24x7x4		KYD
5716	PROTECTION 3Y Onsite + ADP TSS	3y	36	Onsite		ADP
5723	2Mo Onsite + Priority Support	2m	2	Onsite
7270	PROTECTION 3Y Depot + ADP TSS	3y	36	Depot		ADP

[SamT]

See if this is significantly faster. If it is, then complete it following that pattern

Option Explicit

Enum ColNums
    SKU
    Desc
    Termall
    TermMonths
    Location
    ResponseTime
    ADP
    KYD
    SBTY
End Enum

Sub PArseDescriptions()
Dim Rw As Range

With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
End With

For Each Rw In Range("A1").CurrentRegion.Rows 'Edit A1 to fit the SKU Header Cell
  With Cells(Desc)
  
  'Assume there can be only one
    If InStr(.Value, "1Y") Then
      Cells(Termall) = "1Y"
      Cells(TermMonths) = 12
    ElseIf InStr(.Value, "2Y") Then
      Cells(Termall) = "2Y"
      Cells(TermMonths) = 24
    ElseIf InStr(.Value, "3Y") Then
      Cells(Termall) = "3Y"
      Cells(TermMonths) = 38
    ElseIf InStr(.Value, "1Y") Then
      Cells(Termall) = "1Y"
      Cells(TermMonths) = 12
  
    ElseIf InStr(.Value, "1M") Then
      Cells(Termall) = "1M"
      Cells(TermMonths) = 1
    ElseIf InStr(.Value, "2M") Then
      Cells(Termall) = "2M"
      Cells(TermMonths) = 2
    ElseIf InStr(.Value, "3M") Then
      Cells(Termall) = "3M"
      Cells(TermMonths) = 3
    ElseIf InStr(.Value, "4M") Then
      Cells(Termall) = "4M"
      Cells(TermMonths) = 4
    End If
    
    'Only one
    If InStr(.Value, "Onsite") Then
      Cells(Location) = "OnSite"
    ElseIf InStr(.Value, "ElseWhere") Then
      Cells(Location) = "ElseWhere"
    End If
    
    If InStr(.Value, "24x7x4") Then Cells(ResponseTime) = "24x7x4"
    
    'Only one
    If InStr(.Value, "ADP") Then
      Cells(ADP) = "ADP"
    ElseIf InStr(.Value, "KYD") Then
      Cells(KYD) = "KYD"
    ElseIf InStr(.Value, "SBTY") Then
      Cells(SBTY) = "SBTY"
    End If
  End With
Next Rw
  
With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
End With

End Sub

[SamT]

You can pick up more speed by arranging the internals of each set of If...Then...ElseIf's from most common to least common.

Example, if the most common "Term" offered is 2Y, then 1M, then 3Y,then all the rest
Arrange the Ifs like

    If InStr(.Value, "2Y") Then
      Cells(Termall) = "2Y"
      Cells(TermMonths) = 24
    ElseIf InStr(.Value, "1M") Then
      Cells(Termall) = "1M"
      Cells(TermMonths) = 1
    ElseIf InStr(.Value, "3Y") Then
      Cells(Termall) = "3Y"
      Cells(TermMonths) = 36
Etc, etc,etc

[wpaj1025]

See if this is significantly faster. If it is, then complete it following that pattern

Option Explicit

Enum ColNums
    SKU
    Desc
    Termall
    TermMonths
    Location
    ResponseTime
    ADP
    KYD
    SBTY
End Enum

Sub PArseDescriptions()
Dim Rw As Range

With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
End With

For Each Rw In Range("A1").CurrentRegion.Rows 'Edit A1 to fit the SKU Header Cell
  With Cells(Desc)
  
  'Assume there can be only one
    If InStr(.Value, "1Y") Then
      Cells(Termall) = "1Y"
      Cells(TermMonths) = 12
    ElseIf InStr(.Value, "2Y") Then
      Cells(Termall) = "2Y"
      Cells(TermMonths) = 24
    ElseIf InStr(.Value, "3Y") Then
      Cells(Termall) = "3Y"
      Cells(TermMonths) = 38
    ElseIf InStr(.Value, "1Y") Then
      Cells(Termall) = "1Y"
      Cells(TermMonths) = 12
  
    ElseIf InStr(.Value, "1M") Then
      Cells(Termall) = "1M"
      Cells(TermMonths) = 1
    ElseIf InStr(.Value, "2M") Then
      Cells(Termall) = "2M"
      Cells(TermMonths) = 2
    ElseIf InStr(.Value, "3M") Then
      Cells(Termall) = "3M"
      Cells(TermMonths) = 3
    ElseIf InStr(.Value, "4M") Then
      Cells(Termall) = "4M"
      Cells(TermMonths) = 4
    End If
    
    'Only one
    If InStr(.Value, "Onsite") Then
      Cells(Location) = "OnSite"
    ElseIf InStr(.Value, "ElseWhere") Then
      Cells(Location) = "ElseWhere"
    End If
    
    If InStr(.Value, "24x7x4") Then Cells(ResponseTime) = "24x7x4"
    
    'Only one
    If InStr(.Value, "ADP") Then
      Cells(ADP) = "ADP"
    ElseIf InStr(.Value, "KYD") Then
      Cells(KYD) = "KYD"
    ElseIf InStr(.Value, "SBTY") Then
      Cells(SBTY) = "SBTY"
    End If
  End With
Next Rw
  
With Application
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
End With

End Sub

SamT,

Thank you very much. Much quicker and efficient

[wpaj1025]

Thanks