Replacing Text evenly from 1 sheet to another sheet

Hi,

I need help for creating a macro that can replace text on Sheet 1 to the text on Sheet 2. (see attachment file) Attachment 21398


Eg.

In sheet 1

Part 1, it consists of
Data 10
Data 15
Data 35
Data 20
Data 30
Data 10

Part 2, it consists of
Data 35
Data 50
Data 10
Data 15
Data 30

Part 3, it consists of
Data 30
Data 32
Data 10
Data 15
Data 10



In sheet 2

It consists of
10 LADY
10 CHILDREN
10 MAN
10 HAZMAT

30 BROADER
30 INSPIRATIONAL
30 STORY MATTER

How can I replace all DATA 10 to 10 LADY, 10 CHILDREN, 10 MAN and 10 HAZMAT rotate evenly over all the PART of sheet 1
and also replace DATA 30 with 30 BROADER, 30 INSPIRATIONAL and 30 STORY MATTER rotate evenly over all the PART of sheet 1.

P.S. There are more that 10 parts, I'm giving example for 3 parts only.

I tried this formula but dont really work my cases.

Sub Multi_FindReplace()

Dim sht As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long

fndList = Array("DATA 10")
rplcList = Array("10 LADY", "10 CHILDREN", "10 MAN", "10 HAZMAT")


For x = LBound(fndList) To UBound(fndList)

For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht

Next x

End Sub



Please help.

Thanks

I can't understand your requirement at all, please can you upload a workbook which shows how your data is arranged and also how you want the data to look after the macor has been run. Then we might be able tohelp.

Enlighten us. What are parts?

I sort of think I might just maybe understand

I didn't know if you wanted the replacements to start over each time there's a new PART, so this version doesn't start over when PART changes

So 6, 13, 15 and 23 are replaced with the first, second, third, and then the first again since there are only 3 "DATA 30" replacements

It can be added

Attachment 21410

Code:

---

Option Explicit
Option Base 1

Dim rOriginal As Range, rReplace As Range
Sub Rotate()
    Dim rArea As Range, rStart As Range
    Dim vBlock()    As Variant
    Dim n As Long
   
    Application.ScreenUpdating = False
   
    'note space in sheet name
    Set rOriginal = Worksheets("Sheet 1").Range("A:A").SpecialCells(xlCellTypeConstants)
    Set rReplace = Worksheets("Sheet 2").Range("A:F").SpecialCells(xlCellTypeConstants)
   
    For Each rArea In rReplace.Areas
        'make even single cell areas into array starting at 1
        If rArea.Cells.Count = 1 Then
            vBlock = Array(rArea.Value)
            ReDim Preserve vBlock(1 To 1)
        Else
            vBlock = Application.WorksheetFunction.Transpose(rArea.Value)
        End If
       
        Call ReplaceBlock(vBlock())
    Next
   
    Application.ScreenUpdating = True
End Sub
   
   
Private Sub ReplaceBlock(A() As Variant)
    Dim C As Range
    Dim n As Long
    Dim firstAddress As String
    Dim sPrefix As String
   
    sPrefix = Left(A(1), 2)
   
    n = 1
   
    With rOriginal
        Set C = .Find("DATA " & sPrefix, LookIn:=xlValues)
   
        If Not C Is Nothing Then
            firstAddress = C.Address
            Do
                C.Value = A(n)
                n = n + 1
                If n > UBound(A) Then n = 1
                Set C = .FindNext(C)
            Loop While Not C Is Nothing
        End If
    End With
End Sub

---

Thank you Paul. You are great. :thumb This is exactly what I wanted.

Another question. Currently I have DATA 10, DATA 15, DATA 20, DATA 30, DATA 32 and DATA 35. What if I have an additional DATA 60. Where do i change the formula? And also your formula link to the numbers matching the DATA no. What if the lookup data doesnt have a number attach to it.

1. I added some DATA 60 to Sheet2. As long as they're in a separate group and you adjust these lines

Code:

---

    Set rOriginal = Worksheets("Sheet 1").Range("A:A").SpecialCells(xlCellTypeConstants)
    Set rReplace = Worksheets("Sheet 2").Range("A:F").SpecialCells(xlCellTypeConstants)

---

2. It's the number on DATAxx that is used to link the other data

Quote:

---

Originally Posted by Paul_Hossler

1. I added some DATA 60 to Sheet2. As long as they're in a separate group and you adjust these lines

Code:

---

    Set rOriginal = Worksheets("Sheet 1").Range("A:A").SpecialCells(xlCellTypeConstants)
    Set rReplace = Worksheets("Sheet 2").Range("A:F").SpecialCells(xlCellTypeConstants)

---

2. It's the number on DATAxx that is used to link the other data

---

2. No, DATAxx is not used to link other data.


Thanks for your help though but I've achieved what I wanted. Here are the example that I need and maybe I would share it here, DataXX not link to other data.

Sub replaceData()

Dim Ary10 As Variant
Dim Cnt As Long
Dim Qty As Long
Dim Fnd As Range
Dim i As Long

Ary10 = Array("LADY", "CHILDREN", "MAN", "HAZMAT")
Qty = WorksheetFunction.CountIf(Columns(1), "DATA 10")
For Cnt = 1 To Qty
Set Fnd = Columns(1).Find("DATA 10", , , xlWhole, , , False, , False)
If Not Fnd Is Nothing Then
Fnd.Value = Ary10(i)
i = i + 1
If i > UBound(Ary10) Then i = 0
End If
Next Cnt

End Sub

1. Glad you have something that works

2. Although that does seem a little different from first request

Quote:

---

How can I replace all DATA 10 to 10 LADY, 10 CHILDREN, 10 MAN and 10 HAZMAT rotate evenly over all the PART of sheet 1
and also replace DATA 30 with 30 BROADER, 30 INSPIRATIONAL and 30 STORY MATTER rotate evenly over all the PART of sheet 1.

---

I'd use:

Code:

---

Sub M_snb()
  sn = Array("LADY", "CHILDREN", "MAN", "HAZMAT")

  for j=0 to ubound(sn)
    columns(1).find("DATA 10").value=sn(j)
  Next
End Sub

---