Unoptimized VBA macro that edits cell values based on a partial string

Question

This macro is used to check if a partial string is present in a cell. Since the partial string is part of a product reference number, I have a lot of combinations. Is it possible to write these partial string combinations more efficient?

Macro

Sub Contain_Copy()
 Dim ranger As Long
 Dim lastrow As Long
 Dim FromSheet As Worksheet, ToSheet As Worksheet
Set FromSheet = Sheets("C")
lastrow = FromSheet.Cells(Rows.Count, "N").End(xlUp).Row
For ranger = 2 To lastrow
 If InStr(1, FromSheet.Cells(ranger, "N"), "ET7", vbTextCompare) > 0 Then
 FromSheet.Cells(ranger, 3) = FromSheet.Cells(ranger, 3) & " " & " zilver spits Endcap"
 FromSheet.Cells(ranger, 4) = FromSheet.Cells(ranger, 4) & " " & " Titanium Pointy Endcap"
 FromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:= "Uitgevoerd in zilver met endcap Big07."
 FromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:= "Available in Titanium with endcap Big07."
 End If
Next ranger
For ranger = 2 To lastrow
 If InStr(1, FromSheet.Cells(ranger, "N"), "ET6", vbTextCompare) > 0 Then
 FromSheet.Cells(ranger, 3) = FromSheet.Cells(ranger, 3) & " " & " zilver open Endcap"
 FromSheet.Cells(ranger, 4) = FromSheet.Cells(ranger, 4) & " " & " Titanium Round Endcap"
 FromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:= "Uitgevoerd in zilver met endcap Big06."
 FromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:= "Available in Titanium with endcap Big06."
 End If
Next ranger
For ranger = 2 To lastrow
 If InStr(1, FromSheet.Cells(ranger, "N"), "EN7", vbTextCompare) > 0 Then
 FromSheet.Cells(ranger, 3) = FromSheet.Cells(ranger, 3) & " " & " zwart RVS spits Endcap"
 FromSheet.Cells(ranger, 4) = FromSheet.Cells(ranger, 4) & " " & " Black Stainless Pointy Endcap"
 FromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:= "Uitgevoerd in zwart RVS met endcap Big07."
 FromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:= "Available in black stainless steel with endcap Big07."
 End If
Next ranger
For ranger = 2 To lastrow
 If InStr(1, FromSheet.Cells(ranger, "N"), "EN6", vbTextCompare) > 0 Then
 FromSheet.Cells(ranger, 3) = FromSheet.Cells(ranger, 3) & " " & " zwart RVS open Endcap"
 FromSheet.Cells(ranger, 4) = FromSheet.Cells(ranger, 4) & " " & " Black Stainless Round Endcap"
 FromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:= "Uitgevoerd in zwart RVS met endcap Big06."
 FromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:= "Available in black stainless steel with endcap Big06."
 End If
Next ranger
For ranger = 2 To lastrow
 If InStr(1, FromSheet.Cells(ranger, "N"), "ES7", vbTextCompare) > 0 Then
 FromSheet.Cells(ranger, 3) = FromSheet.Cells(ranger, 3) & " " & "stainless spits Endcap"
 FromSheet.Cells(ranger, 4) = FromSheet.Cells(ranger, 4) & " " & "Stainless Pointy Endcap"
 FromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:= "Uitgevoerd in stainless steel met endcap Big07."
 FromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:= "Available in stainless steel with endcap Big07."
 End If
Next ranger
For ranger = 2 To lastrow
 If InStr(1, FromSheet.Cells(ranger, "N"), "ES6", vbTextCompare) > 0 Then
 FromSheet.Cells(ranger, 3) = FromSheet.Cells(ranger, 3) & " " & "stainless open Endcap"
 FromSheet.Cells(ranger, 4) = FromSheet.Cells(ranger, 4) & " " & "Stainless Round Endcap"
 FromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:= "Uitgevoerd in stainless steel met endcap Big06."
 FromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:= "Available in stainless steel with endcap Big06."
 End If
Next ranger
End sub

(This is only a part of the code, but I think you get the gist.)

It's a VBA macro that looks for a partial string, and if the partial string is found, it pastes a value in a column, and changes a value in another column. As you can see, I'm looking for a lot of partial strings that have slight variations. I have the feeling, that this code can be optimized, but I have no idea how I should approach this.

• πάντα ῥεῖ: Please specify in your title and explanation what this macro is supposed to do.
• FreeMan: Also, please specify what it is that you're looking for in the review. If you'll take the Tour, you'll see what it takes to make a good CR question and, thus, get a good code review.
• Berend Starkenburg: @FreeMan I tried to be more specific in my description and I changed the title. Do you think it is better this way?
• FreeMan: I posted some thoughts, but I'm not sure what you're really after - speed, general clean up, something else?

Answer 1

Off the top of my head, you can eliminate all but one of the For loops.

Sub Contain_Copy()
 Dim ranger As Long
 Dim lastRow As Long
 Dim fromSheet As Worksheet
 Dim toSheet As Worksheet
 Set fromSheet = Sheets("C")
 lastRow = fromSheet.Cells(Rows.Count, "N").End(xlUp).Row
 For ranger = 2 To lastRow
 If InStr(1, fromSheet.Cells(ranger, "N"), "ET7", vbTextCompare) > 0 Then
 fromSheet.Cells(ranger, 3) = fromSheet.Cells(ranger, 3) & " " & " zilver spits Endcap"
 fromSheet.Cells(ranger, 4) = fromSheet.Cells(ranger, 4) & " " & " Titanium Pointy Endcap"
 fromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:="Uitgevoerd in zilver met endcap Big07."
 fromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:="Available in Titanium with endcap Big07."
 End If
 If InStr(1, fromSheet.Cells(ranger, "N"), "ET6", vbTextCompare) > 0 Then
 fromSheet.Cells(ranger, 3) = fromSheet.Cells(ranger, 3) & " " & " zilver open Endcap"
 fromSheet.Cells(ranger, 4) = fromSheet.Cells(ranger, 4) & " " & " Titanium Round Endcap"
 fromSheet.Replace What:="Uitgevoerd in Zwart RVS met endcap Big06.", Replacement:="Uitgevoerd in zilver met endcap Big06."
 fromSheet.Replace What:="Available in black stainless steel with endcap Big06.", Replacement:="Available in Titanium with endcap Big06."
 End If
'The rest of the IF statements go here
 Next ranger
End Sub

That should speed up execution a bit by not having to run through all the rows multiple times.

You'll probably want to explicitly specify which workbook after when you Set fromSheet = Sheets("C") by using ThisWorkbook.Sheets("C"). It's probably not a big deal for this particular procedure, but it's a good idea to get in the habit of always using fully qualified references. Sheets() refers to the current workbook, and in more complex code, you may have activated a different workbook at some point, or your user may have gotten bored watching some long-running code and click on a different workbook - all of a sudden, in the next loop Sheets() refers to a totally different workbook and your code does strange thingsTM.

It feels like there should be some way of parameterizing all the text bits that you're adding on or replacing, but either there aren't enough changes happening to make it worthwhile, or we're not seeing enough of the code to find the patterns that would make it worthwhile. Something like this, but again, I'm not sure if it's worth it:

Const engTi As String = "Titanium"
Const deTi As String = "zilver"
Const engBlackStainless As String = "black stainless steel"
Const deBlackStainless As String = "Zwart RVS"
 If InStr(1, fromSheet.Cells(ranger, "N"), "ET7", vbTextCompare) > 0 Then
 fromSheet.Cells(ranger, 3) = fromSheet.Cells(ranger, 3) & " " & " zilver spits Endcap"
 fromSheet.Cells(ranger, 4) = fromSheet.Cells(ranger, 4) & " " & " Titanium Pointy Endcap"
 fromSheet.Replace What:="Uitgevoerd in " & deBlackStainless & " met endcap Big06.", Replacement:="Uitgevoerd in zilver met endcap Big07."
 fromSheet.Replace What:="Available in " & engBlackStainless & " with endcap Big06.", Replacement:="Available in Titanium with endcap Big07."
 End If

The text strings probably belong in a DescriptiveStringClass - a "resource file" of some sort with a Getter to pull them out, but that's probably serious overkill if the code is really this short. Sometimes, some ugly looking text is just really the best way to go.

EDIT:

With 52 different possibilities to check, I'd pull all the updating lines into their own subroutine. Something like this:

Sub Contain_Copy()
 Dim ranger As Long
 Dim lastRow As Long
 Dim fromSheet As Worksheet
 Dim toSheet As Worksheet
 Set fromSheet = Sheets("C")
 lastRow = fromSheet.Cells(Rows.Count, "N").End(xlUp).Row
 For ranger = 2 To lastRow
 If InStr(1, fromSheet.Cells(ranger, "N"), "ET7", vbTextCompare) > 0 Then
 UpdateCells fromSheet, ranger, "Titanium Pointy Endcap", "zilver spits Endcap", _
 "Uitgevoerd in Zwart RVS met endcap Big06.", "Uitgevoerd in zilver met endcap Big07.", _
 "Available in black stainless steel with endcap Big06.", "Available in Titanium with endcap Big07."
 End If
 If InStr(1, fromSheet.Cells(ranger, "N"), "ET6", vbTextCompare) > 0 Then
 UpdateCells fromSheet, ranger, "Titanium Round Endcap", "zilver open Endcap", _
 "Uitgevoerd in Zwart RVS met endcap Big06.", "Uitgevoerd in zilver met endcap Big06.", _
 "Available in black stainless steel with endcap Big06.", "Available in Titanium with endcap Big06."
 End If
 'The rest of the IF statements go here
 Next ranger
End Sub
Private Sub UpdateCells(ByVal TheSheet As Worksheet, ByVal TheRow As Long, ByVal ShortEng As String, ByVal ShortDe As String, _
 ByVal SearchEng As String, ByVal ReplaceEng As String, ByVal SerchDe As String, ByVal ReplaceDe As String)
 Const aSpace As String = " "
 TheSheet.Cells(TheRow, 3) = TheSheet.Cells(TheRow, 3) & aSpace & ShortDe
 TheSheet.Cells(TheRow, 4) = TheSheet.Cells(TheRow, 4) & aSpace & ShortEng
 TheSheet.Replace what:=searchde, replacement:=ReplaceDe
 TheSheet.Replace what:=SearchEng, replacement:=ReplaceEng
End Sub

• Berend Starkenburg: The small parts of text refer to a product ID from motor exhausts. I want to search for these small parts, since they stand for the color and shape of the exhaust (in this instance the "T" in "ET7" stand for the color titanium.) So when the product ID contains ET7 I want my macro to add these characteristics to my product description and product name. In total there are 20 combinations. However some of the product IDs don't end on a number, so I need to make it unique by adding the numbers 1 to 9 before the small part of text.Because of this there are a total of 52 possible combinations.