PDA

View Full Version : [SOLVED] VBA Code to filter a list, then create new list in a new column



wpaj1025
02-08-2017, 11:24 AM
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
02-08-2017, 12:49 PM
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
02-08-2017, 01:01 PM
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
02-08-2017, 03:41 PM
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
02-08-2017, 03:42 PM
Thanks