How to Optimize This Code?

Good night people,

I have a task to do which I use a find and replace code that works by selection:

Sub MultiFindNReplace()
'Update 20140722
Dim Rng As Range
Dim InputRng As Range, ReplaceRng As Range
xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Original Range ", xTitleId, InputRng.Address, Type:=8)
Set ReplaceRng = Application.InputBox("Replace Range :", xTitleId, Type:=8)
Application.ScreenUpdating = False
   
For Each Rng In ReplaceRng.Columns(1).Cells
    InputRng.Replace what:=Rng.Value, replacement:=Rng.Offset(0, 1).Value, Lookat:=xlWhole
Next
Application.ScreenUpdating = True
End Sub

The code is great and does the job, but it can take hours to process when I'm working on a 100K rows with cells to be found and replaced by 100k different matches from another worksheet.

Could anyone suggest me something to improve the performance?


PS: I'm not exactly sure how it affects the coding, but the column contains blank cells between the values. Maybe telling it to auto skip it would save it some time? (sorry if it sounds stupid, I'm kind of new with excel)

See if this helps

Sub MultiFindNReplace()
'Update 20140722
    Dim Rng        As Range
    Dim InputRng   As Range
    Dim ReplaceRng As Range
    Dim xTitleId   As String
    xTitleId = "KutoolsforExcel"
    With Application
        Set InputRng = .InputBox("Original Range ", xTitleId, Selection.Address, Type:=8)
        Set ReplaceRng = .InputBox("Replace Range :", xTitleId, Type:=8)
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        For Each Rng In ReplaceRng.Columns(1).Cells
            If Rng.Value <> Empty Then
                InputRng.Replace what:=Rng.Value, replacement:=Rng.Offset(0, 1).Value, Lookat:=xlWhole
            End If
        Next
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Good morning AlphaFrog, thank you for the reply

I saw your message yesterday and left the code running through the night. I can't really tell if it made it somehow faster, as it was still running in the morning when I woke up, but I found out something interesting. When I press ESC and end the code, the data seems to have been replaced properly, although the code was running as far as I could check everything was actually replaced, maybe something makes the code keep running for some reason.

I will upload a small sample as suggested by our friend above, that way you can see how the data is structured. All columns are located in the correct position according to the original file, but as the code works by selection, I only pasted the columns that are affected.


PS: Sheet3 has the column that's gonna be replaced, based on the 2 columns in the other sheet. I also didn't mention that the column with the data to be replaced has a text "Código" as a header, which is used later on for another code, and also the dates, both data that can't be deleted, but maybe could be causing the problem

Hello Jolivanes, thanks for the reply!

I'm uploading here a small sample of the file. I gave some information above that might be relevant to us.

What are you actually wanting to achieve here...can you explain the process...
What would the first range selection be and what must replace what?

Must sheet3's product code be replace by sheet4 corresponding Code category...And why must the ranges be selected...Surely all must just be updated?
i.e.
202350 replaced by 64?

Originally Posted by sintek

What are you actually wanting to achieve here...can you explain the process...

Hello sintek, thanks for the interest!

My goal is to replace all the product codes (SKU) for the category code. I have a periodic data sheet that contains all transactions identifying the client ID. The original the file has all the SKU numbers also, which can be used to identify which category it belongs. I'm not sure if this is the best way of doing it, but for my actual knowledge it suits, as I don't have much more time to study before completing this task. The only reason for selection is that it makes it easier, as each data sheet can vary on lenght and also for using 2 different worksheets.

I tried adapting the code to skip dates and text and it seems to have worked faster, although it still demands a couple hours. I will keep using this for now, until and if someone has any other idea that could help.

Sub MultiFindNReplace()
'Update 20140722
    Dim Rng        As Range
    Dim InputRng   As Range
    Dim ReplaceRng As Range
    Dim xTitleId   As String
    xTitleId = "KutoolsforExcel"
    With Application
        Set InputRng = .InputBox("Original Range ", xTitleId, Selection.Address, Type:=8)
        Set ReplaceRng = .InputBox("Replace Range :", xTitleId, Type:=8)
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        For Each Rng In ReplaceRng.Columns(1).Cells
            If Not IsDate(Rng.Value) Then
            If IsNumeric(Rng.Value) Then
                InputRng.Replace what:=Rng.Value, replacement:=Rng.Offset(0, 1).Value, Lookat:=xlWhole
            End If
            End If
        Next
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

My goal is to replace all the product codes (SKU) for the category code

So why not simply...

Sub J3v16()
With Sheets("Sheet3")
    With .Range("A15:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Offset(, 1)
        .Formula = "=IF(CELL(""format"",A15)=""D1"",A15,IF(ISTEXT(A15),A15,IF(ISBLANK(A15),"""",VLOOKUP(A15,Sheet4!B:C,2,0))))"
        .Copy
        .Offset(, -1).PasteSpecial xlPasteValues
        .Clear
    End With
End With
End Sub

Originally Posted by sintek

So why not simply...
[/CODE]

This worked incredibly fast!!! But some cells that were blank, for some weird reason appear with a date value 00/01/1900. Any idea why?


EDIT: The blank fields were formatted as dates, that's the reason. Duh


Thank you very much sintek!! You just saved me some weeks! s2

As for the other codes, both made my Excel crash after freezing. Anyway, I think the code from the message above might be efficient enough, but I thank you for your help.

Originally Posted by sintek

So why not simply...

Sintek,

There are actually 2 problems with the code. The first is that it clears the following column to the right. It's not a big deal as I can paste it from the original sample. The other problem is whenever I run your macro to replace the codes, I can't run another macro that concatenates the values on column M and N. This other macro works fine with the SKU numbers, and was working fine with the first macro I posted that took hours. I've been checking for hours for any difference between the original sheet and the sheet after running your macro, but I can't find anything different.

When I run this code below, I get a Run Time Error 9 Subscript Out of Range.

Sub findconcat_samecells_arr2()

Dim cel, fr As Range
Dim k, g, ofst, lr, frr As Long
Dim i, j As Long
Dim a()
        
    Application.ScreenUpdating = False
        Columns("M:M").NumberFormat = "@"
        Range("M18:N" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
        a = Range(Cells(1, 1), Cells(Cells(Rows.Count, 2).End(xlUp).Row + 1, 14))

    For i = LBound(a) To UBound(a)
           If a(i, 6) Like "???[.]???[.]???[-]??" Then
            For j = i To UBound(a)
                   If InStr(a(j, 1), "digo") > 1 Then
                       frr = j '20
                    GoTo Nxt
                    End If
                Next j
Nxt:
            On Error Resume Next
            ofst = Range(Cells(i, 1), Cells(frr, 1)).SpecialCells(xlCellTypeBlanks).Count
            If ofst Is Nothing Then
                ofst = 0
            End If
            On Error GoTo 0
            k = 1 + ofst
            Do While Not IsEmpty(a(j + k, 1))
                    If InStr(a(j + k, 1), "digo") < 1 Then
                        Cells(i, 13).Value = Cells(i, 13).Value & ", " & a(j + k, 1)
                    End If
                k = k + 1
            Loop
                g = 0
                Do While Not IsEmpty(a(i + g, 7))
                    If g = 0 Then
                        a(i, 14) = a(i + g, 7)
                    Else
                        a(i, 14) = a(i + g, 7) & "," & a(i, 14)
                    End If
                    Cells(i, 14).Value = a(i, 14)
                g = g + 1
                Loop
            End If
        Next i

        Application.ScreenUpdating = True
        End Sub

Any idea what could be causing the problem?


EDIT: The code above concatenates all values into a single cell, instead of working and supposed: counting the blanks and the text "Código" to determine a group of data that belongs to a single customer ID. I'm not sure how this helps, but the info might be useful

Maybe try

Sub repl()
Dim IRng As Range, RRng As Range
With Sheets("Sheet3")
    Set IRng = .Range("A16", .Cells(Rows.Count, 1).End(xlUp))
    Set RRng = Sheets("Sheet4").[B2].CurrentRegion
    IRng = Evaluate(Replace("IF(N(+#)*(" & IRng.Offset(1).Address & "<9^99),iferror(VLOOKUP(N(IF(1,+#)), " & RRng.Parent.Name & "!" & RRng.Address & ",2,0),#),#&"""")", "#", IRng.Address))
End With
End Sub

Does this work for you?
Change references where required.

Sub Maybe()
Dim a, b, i As Long, j As Long
Dim sh3 As Worksheet, sh4 As Worksheet
Set sh3 = Worksheets("Sheet3")
Set sh4 = Worksheets("Sheet4")
a = sh3.Range("A15:A" & sh3.Cells(Rows.Count, 1).End(xlUp).Row).Value
b = sh4.Range("B1:C" & sh4.Cells(Rows.Count, 3).End(xlUp).Row).Value
    For i = LBound(a) To UBound(a)
        If Not IsDate(a(i, 1)) And Not WorksheetFunction.IsText(a(i, 1)) And IsNumeric(a(i, 1)) Then
            On Error Resume Next    'Skip blank cells and cells with spaces
                a(i, 1) = b(Application.Match(a(i, 1), Application.Index(b, , 1), 0), 2)
            On Error GoTo 0
        End If
    Next i
sh3.Cells(15, 3).Resize(UBound(a)).Value = a    '<---- Change where you want the output to be. Here it is 2 columns over to the right
End Sub

With 100,000 rows of data in Sheet3 and no changes to Sheet4, it took 3 seconds on my old machine with excel 2007.

Post 10 above is actually the way to go with this problem...as it just references the required column and replaces the correct lookup found values...

The first is that it clears the following column to the right

This was just a solution for your sample file uploaded...One would need to use a helper column at end of data...

I can't run another macro that concatenates the values on column M and N

As far as above...One can only see if you upload a sample file to test...As we cannot recreate the issue

Just for future reference...the below declarations...
Only the red ones are actually declared...the ones prior without As are declared as variants...

Dim cel, fr As Range
Dim k, g, ofst, lr, frr As Long
Dim i, j As Long

Should be...

Dim cel As Range, fr As Range
Dim k As Long, g As Long, ofst As Long, lr As Long, frr As Long
Dim i As Long, j As Long