Expert VBA Code Help Needed (Find & Replace)

[LukeWayne]

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.

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

 

[JLGWhiz]

If I understand correctly, you have a list of manufacturer codes and a value in column A of sheet 1 and you want to modify the current content of each cell by adding any additional values found in sheet 2 column A when the sheet 2 column B value is fount in sheet 1 column A. If that is a correct analogy then this should work.

Sub beefup()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range, dst As Range, lr As Long, rng As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh2.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = sh2.Range("B1:B" & lr)
rng.AdvancedFilter xlFilterCopy, , sh2.Cells(lr + 2, 1), True
    For Each c In sh2.Cells(lr + 2, 1).Offset(1).Resize(sh2.Cells(lr + 2, 1).CurrentRegion.Rows.Count - 1)
    Set fn = rng.Find(c.Value, , xlValues, xlWhole)
        If Not fn Is Nothing Then
            fAdr = fn.Address
            Do
                Set dst = sh1.Range("A:A").Find(c.Value, , xlValues, xlPart)
                If Not dst Is Nothing Then
                    If InStr(dst.Value, fn.Offset(, -1).Value) = 0 Then
                        dst = dst.Value & ", " & fn.Offset(, -1).Value
                    End If
                End If
                Set fn = rng.FindNext(fn)
            Loop While fAdr <> fn.Address
        End If
    Next
    sh2.Cells(lr + 2, 1).CurrentRegion.ClearContents
End Sub

 

[LukeWayne]

If I understand correctly, you have a list of manufacturer codes and a value in column A of sheet 1 and you want to modify the current content of each cell by adding any additional values found in sheet 2 column A when the sheet 2 column B value is fount in sheet 1 column A. If that is a correct analogy then this should work.

Sub beefup()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range, fn As Range, dst As Range, lr As Long, rng As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh2.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = sh2.Range("B1:B" & lr)
rng.AdvancedFilter xlFilterCopy, , sh2.Cells(lr + 2, 1), True
    For Each c In sh2.Cells(lr + 2, 1).Offset(1).Resize(sh2.Cells(lr + 2, 1).CurrentRegion.Rows.Count - 1)
    Set fn = rng.Find(c.Value, , xlValues, xlWhole)
        If Not fn Is Nothing Then
            fAdr = fn.Address
            Do
                Set dst = sh1.Range("A:A").Find(c.Value, , xlValues, xlPart)
                If Not dst Is Nothing Then
                    If InStr(dst.Value, fn.Offset(, -1).Value) = 0 Then
                        dst = dst.Value & ", " & fn.Offset(, -1).Value
                    End If
                End If
                Set fn = rng.FindNext(fn)
            Loop While fAdr <> fn.Address
        End If
    Next
    sh2.Cells(lr + 2, 1).CurrentRegion.ClearContents
End Sub

Sheet 1 has a Column with manufacturer numbers (Column AM) and this Column matches Column B from Sheet 2 ( Column B is not identical obviously as they are used as a reference to look up and cross reference) of which equal the values of Column A on Sheet 2 (Column A are the replacement values). However, the problem is that Column B manufacturer numbers repeat themselves, thus making the Sheet 1 Column AM with manufacturer numbers equal to two values from Column A Sheet 2 in some cases. (My current VBA code only allowed for one value to replace and not two values when needed) In these cases I would like the macro to allow for two values to replace the manufacturer number in Column AM when needed.

So with that would this code you posted still work?

Here is Sheet 1 Image:

 

[JLGWhiz]

So with that would this code you posted still work?

No, the posted code would need to be modified. I used the wrong column for sheet 1 in my code. I am trying to digest your description of the sheet 1 data layout to determine how best to approch the issue.

 

[LukeWayne]

No, the posted code would need to be modified. I used the wrong column for sheet 1 in my code. I am trying to digest your description of the sheet 1 data layout to determine how best to approch the issue.

Okay, I appreciate your help! I would gladly send you the spreadsheet if it meant figuring this out any faster. You may PM me.

 

[JLGWhiz]

Okay, I appreciate your help! I would gladly send you the spreadsheet if it meant figuring this out any faster. You may PM me.

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

Taking a closer look at this code from the OP, it appears that you are replacing the manufacturer code number in Range ("AM2:AQ" & frow) with the value from column A of sheet 2. Is that what you really meant to do? I was working toward finding the manufacturer code and then replacing a single value matching column A, sheet2 with all the values for that mfr code from column A, sheet2. Which do you want? Maybe a better question, which would work? Can you describe the cell content of the cells in sheet 1, Range("AM:AQ)? Maybe show a screen shot of that range or a portion of it.

 

[LukeWayne]

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

Taking a closer look at this code from the OP, it appears that you are replacing the manufacturer code number in Range ("AM2:AQ" & frow) with the value from column A of sheet 2. Is that what you really meant to do? I was working toward finding the manufacturer code and then replacing a single value matching column A, sheet2 with all the values for that mfr code from column A, sheet2. Which do you want? Maybe a better question, which would work? Can you describe the cell content of the cells in sheet 1, Range("AM:AQ)? Maybe show a screen shot of that range or a portion of it.

Look two posts above this and you can see a screen shot of Sheet 1. I only need one column and not multiple. Again this VBA code is something I am trying to modify from a previous use.

 

[JLGWhiz]

Look two posts above this and you can see a screen shot of Sheet 1. I only need one column and not multiple. Again this VBA code is something I am trying to modify from a previous use.

this is what I had envisioned as a before and after, so tell me what you want to see as a result.
Before: Sheet 2

val	mfr
12.1	123a
13.1	234b
14.1	345c
15.1	456d
16.1	567e
17.1	123a
18.1	234b
19.1	345c
20.1	678f
21.1	345c
22.1	456d
23.1	567e
24.1	123a

<tbody>
</tbody>

After: Sheet 1

AM

123a, 12.1, 17.1, 24.1

234b, 13.1, 18.1

345c, 14.1, 19.1, 21.1

456d, 15.1. 22.1

567e, 16.1, 23.1

678f, 20.1

<tbody>
</tbody>

 

[LukeWayne]

this is what I had envisioned as a before and after, so tell me what you want to see as a result.
Before: Sheet 2

val	mfr
12.1	123a
13.1	234b
14.1	345c
15.1	456d
16.1	567e
17.1	123a
18.1	234b
19.1	345c
20.1	678f
21.1	345c
22.1	456d
23.1	567e
24.1	123a

<tbody>
</tbody>

After: Sheet 1

AM

123a, 12.1, 17.1, 24.1

234b, 13.1, 18.1

345c, 14.1, 19.1, 21.1

456d, 15.1. 22.1

567e, 16.1, 23.1

678f, 20.1

<tbody>
</tbody>

That looks right! The manufacturer number doesn't have to still be in Sheet 1 Column though, only the values.

 

[JLGWhiz]

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.

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