Expert VBA Code Help Needed (Find & Replace)

L

LukeWayne

New Member
Joined
Feb 18, 2017
Messages
24
1. This code below works for another purpose, but I can't figure out what to change for another use when Column B (sheet 2) has manufacturer numbers that repeat themselves. I have attached a picture below to show you (sheet 2) and how the numbers repeat.

2. What I want it to do: For example, Sheet 1 has "3130LF" listed once in a column and is = both 64.946 & 10.494 and I want the macro to replace the manufacturer number in Sheet 1 with both numbers (right now it is only choosing one number to replace with from Sheet 2). And by the way I am only working with one column in Sheet 1 (this VBA code is something I have used in the past and am trying to modify for this purpose. I am not an expert). In theory if "3130LF" is = both 64.946 & 10.494, then maybe I could have the macro run in a way that would replace "3130LF" with 64.946, 10.494 or put both in two separate columns if that would be easier.

e5ib81.jpg


Code: 
Option Explicit
Option Compare Text

Sub FIND_AND_REPLACE()
On Error Resume Next
Application.ScreenUpdating = False

Dim toFind As String, toReplace As String, rng As Range, cel As Range, i As Long, frow As Long, _
frowT As Long, wk As Worksheet, ws As Worksheet, j As Long
Set wk = Sheet1: Set ws = Sheet2

frow = wk.Range("AM" & Rows.Count).End(xlUp).Row
frowT = ws.Range("A" & Rows.Count).End(xlUp).Row

Set rng = wk.Range("AM2:AQ" & frow)

For i = 2 To frowT
toFind = ws.Range("B" & i).Value
toReplace = ws.Range("A" & i).Value
rng.Replace What:=toFind, Replacement:=toReplace, LookAt:=xlWhole, MatchCase:=False
Next i

For i = 2 To frow
wk.Range("AR" & i) = ""

For j = 39 To 43
If Trim(wk.Cells(i, j)) <> "" Then
wk.Range("AR" & i) = wk.Range("AR" & i) & "," & Trim(wk.Cells(i, j))
End If
Next j

If Trim(wk.Range("AR" & i)) <> "" Then
wk.Range("AR" & i) = Right(wk.Range("AR" & i), Len(wk.Range("AR" & i)) - 1)
End If

Next i

Application.ScreenUpdating = True
MsgBox "Done"
End Sub
 
Sort by date Sort by votes
JLGWhiz said:
I have made this into two procedure. The 'prep_Replace' procedure is the procedure to start the action and it will call the 'FIND_AND_REPLACE' procedure. The first procedure accumulates the values in column A into a variable for each unique manufacturer number. Then the manufacturer number and the variable value is fed to second procedure which finds the manufacturer number in the rng range as previously defined in the original code. If found, it replaces the value in the found cell with the value from the sheet 2 variable for column A values. I moved the latter part of your original code to the end of the new procedure and it should do whatever it was doing before. Give it a try.

Code: 
Sub prep_Replace()
Dim wk As Worksheet, ws As Worksheet, c As Range, fn As Range, fAdr As String, rpl As String, frowT As Long
Dim i As Long, j As Long
Set wk = Sheet1
Set ws = Sheet2
frowT = ws.Cells(Rows.Count, 2).End(xlUp).Row
ws.Range("B2:B" & frowT).AdvancedFilter xlFilterCopy, , ws.Cells(frowT + 2, 1), True
Set tmp = ws.Cells(frowT + 2, 1).Resize(ws.Cells(frowT + 2, 1).CurrentRegion.Rows.Count - 1)
    For Each c In tmp
        Set fn = ws.Range("B:B").Find(c.Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                fAdr = fn.Address
                Do
                    rpl = rpl & ", " & fn.Offset(, -1).Value
                    Set fn = ws.Range("B:B").FindNext(fn)
                Loop While fAdr <> fn.Address
            End If
            FIND_AND_REPLACE rpl, c.Value
            rpl = ""
            Set fn = Nothing
    Next
tmp.ClearContents
Set tmp = Nothing
For i = 2 To frow
wk.Range("AR" & i) = ""
For j = 39 To 43
If Trim(wk.Cells(i, j)) <> "" Then
wk.Range("AR" & i) = wk.Range("AR" & i) & "," & Trim(wk.Cells(i, j))
End If
Next j
If Trim(wk.Range("AR" & i)) <> "" Then
wk.Range("AR" & i) = Right(wk.Range("AR" & i), Len(wk.Range("AR" & i)) - 1)
End If
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub


Sub FIND_AND_REPLACE(ByRef rpl As String, ByRef mfr As String)
On Error Resume Next
Application.ScreenUpdating = False
Dim toFind As String, toReplace As String, rng As Range, cel As Range, i As Long, frow As Long, _
frowT As Long, wk As Worksheet, ws As Worksheet, j As Long, fn As Range
Set wk = Sheet1: Set ws = Sheet2
frow = wk.Range("AM" & Rows.Count).End(xlUp).Row
frowT = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = wk.Range("AM2:AQ" & frow)
toFind = mfr
toReplace = rpl
Set fn = rng.Find(toFind, , xlValues, xlWhole)
    If Not fn Is Nothing Then
        fn = rpl
        fn.Characters(1, 1).Delete
    End If
End Sub
Click to expand...

Getting this error:
7255kn.png

167r314.png
 
Upvote 0
LukeWayne said:
I just PMed you the worksheet I am working with.
Click to expand...

I think it just needed a tweak. Check it out.

Code: 
Sub prep_Replace()
Dim wk As Worksheet, ws As Worksheet, c As Range, fn As Range, fAdr As String, rpl As String, frowT As Long
Dim i As Long, j As Long
Set wk = Sheet1
Set ws = Sheet2
frowT = ws.Cells(Rows.Count, 2).End(xlUp).Row
ws.Range("B2:B" & frowT).AdvancedFilter xlFilterCopy, , ws.Cells(frowT + 2, 1), True
Set tmp = ws.Cells(frowT + 2, 1).Offset(1).Resize(ws.Cells(frowT + 2, 1).CurrentRegion.Rows.Count - 1)
    For Each c In tmp
        Set fn = ws.Range("B:B").Find(c.Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                fAdr = fn.Address
                Do
                    rpl = rpl & ", " & CStr(fn.Offset(, -1).Value)
                    Set fn = ws.Range("B:B").FindNext(fn)
                Loop While fAdr <> fn.Address
            End If
            FIND_AND_REPLACE rpl, c.Value
            rpl = ""
            Set fn = Nothing
    Next
tmp.CurrentRegion.ClearContents
Set tmp = Nothing
For i = 2 To frow
wk.Range("AR" & i) = ""
For j = 39 To 43
If Trim(wk.Cells(i, j)) <> "" Then
wk.Range("AR" & i) = wk.Range("AR" & i) & "," & Trim(wk.Cells(i, j))
End If
Next j
If Trim(wk.Range("AR" & i)) <> "" Then
wk.Range("AR" & i) = Right(wk.Range("AR" & i), Len(wk.Range("AR" & i)) - 1)
End If
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub


Sub FIND_AND_REPLACE(ByRef rpl As String, ByRef mfr As String)
On Error Resume Next
Application.ScreenUpdating = False
Dim toFind As String, toReplace As String, rng As Range, cel As Range, i As Long, frow As Long, _
frowT As Long, wk As Worksheet, ws As Worksheet, j As Long, fn As Range
Set wk = Sheet1: Set ws = Sheet2
frow = wk.Range("AM" & Rows.Count).End(xlUp).Row
frowT = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = wk.Range("AM2:AQ" & frow)
toFind = mfr
toReplace = rpl
Set fn = rng.Find(toFind, , xlValues, xlWhole)
    If Not fn Is Nothing Then
        fn = rpl
        fn.Characters(1, 1).Delete
    End If
End Sub
 
Upvote 0
Upvote 0
JLGWhiz said:
I think it just needed a tweak. Check it out.

Code: 
Sub prep_Replace()
Dim wk As Worksheet, ws As Worksheet, c As Range, fn As Range, fAdr As String, rpl As String, frowT As Long
Dim i As Long, j As Long
Set wk = Sheet1
Set ws = Sheet2
frowT = ws.Cells(Rows.Count, 2).End(xlUp).Row
ws.Range("B2:B" & frowT).AdvancedFilter xlFilterCopy, , ws.Cells(frowT + 2, 1), True
Set tmp = ws.Cells(frowT + 2, 1).Offset(1).Resize(ws.Cells(frowT + 2, 1).CurrentRegion.Rows.Count - 1)
    For Each c In tmp
        Set fn = ws.Range("B:B").Find(c.Value, , xlValues, xlWhole)
            If Not fn Is Nothing Then
                fAdr = fn.Address
                Do
                    rpl = rpl & ", " & CStr(fn.Offset(, -1).Value)
                    Set fn = ws.Range("B:B").FindNext(fn)
                Loop While fAdr <> fn.Address
            End If
            FIND_AND_REPLACE rpl, c.Value
            rpl = ""
            Set fn = Nothing
    Next
tmp.CurrentRegion.ClearContents
Set tmp = Nothing
For i = 2 To frow
wk.Range("AR" & i) = ""
For j = 39 To 43
If Trim(wk.Cells(i, j)) <> "" Then
wk.Range("AR" & i) = wk.Range("AR" & i) & "," & Trim(wk.Cells(i, j))
End If
Next j
If Trim(wk.Range("AR" & i)) <> "" Then
wk.Range("AR" & i) = Right(wk.Range("AR" & i), Len(wk.Range("AR" & i)) - 1)
End If
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub


Sub FIND_AND_REPLACE(ByRef rpl As String, ByRef mfr As String)
On Error Resume Next
Application.ScreenUpdating = False
Dim toFind As String, toReplace As String, rng As Range, cel As Range, i As Long, frow As Long, _
frowT As Long, wk As Worksheet, ws As Worksheet, j As Long, fn As Range
Set wk = Sheet1: Set ws = Sheet2
frow = wk.Range("AM" & Rows.Count).End(xlUp).Row
frowT = ws.Range("A" & Rows.Count).End(xlUp).Row
Set rng = wk.Range("AM2:AQ" & frow)
toFind = mfr
toReplace = rpl
Set fn = rng.Find(toFind, , xlValues, xlWhole)
    If Not fn Is Nothing Then
        fn = rpl
        fn.Characters(1, 1).Delete
    End If
End Sub
Click to expand...


Worked Perfectly!!! Thank you for your help! I am now narrowing down the highest value in each cell of which I posted about in another post.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA - Using Replace for Strings
Replies
1
Views
92
Edgar_
Edgar_
L
  • Question Question
VBA code for list box display causing error / crash
Replies
3
Views
2K
dmt32
D
C
  • Solved
VBA, Substitute, Find and Replace, Trim Not working to remove space
Replies
4
Views
202
Alex Blakenburg
A
Guna13
  • Question Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
1K
Guna13
Guna13
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
243
rsolanki
R

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top