Macro to translate values based upon data in another worksheet?

[Riccardinho]

I have a requirement to copy records from one worksheet to another
transposing certain cells in each row into new values based upon th
values in another worksheet.

For example, Sheet 1 contains the following sample values:

CONTACT ID AREA OF INTEREST
1 Football - UK
2 Cricket - India
3 Sport - UK
4 Sport - Europe


Sheet 2 contains a list of the translation values, a la

SOURCE AREA OF INTEREST DESTINATION AREA DESTINATION SPORT
Football - UK UK Football
Cricket - India India Cricket

What I need in Sheet 3 is a denormalised list of records, eg...

CONTACT ID DESTINATION AREA DESTINATION SPORT
1 UK Football
2 India Cricket



However... the situation is complicated by the fact that certain sourc
data transposes to multiple destination data, and I need to create a ne
row for each. So the translation for Sport - UK is

SOURCE AREA OF INTEREST DESTINATION AREA 1 DESTINATION SPOR
1 DESTINATION AREA 2 DESTINATION SPORT 2
Sport - UK UK Football UK Cricket

up to 3 different translations. For this I would need to create i
Sheet 3 the following records:

CONTACT ID DESTINATION AREA DESTINATION SPORT
3 UK Football
3 UK Cricket
and for record 4
4 UK Football
4 UK Cricket
4 Holland Football
4 Holland Cricket

etc etc.


I can get the rows copied to Sheet 3 easily enough, but am strugglin
with the translations and multiple record creations. Any help would b
greatly appreciated

 

[mangesh_yadav]

Sheet 1 has following data in range A1:B4

1 Football - UK
2 Cricket - India
3 Sport - UK
4 Sport - Europe


Sheet 2 has data in range A1:C3

Football - UK UK Football
Cricket - India India Cricket
Cricket - UK UK Cricket


In Sheet 3, place a button from the View > toolbars. Control Toolbox
and assign the following code to this button:

Private Sub CommandButton1_Click()

Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")

Set rngSht1 = sht1.Range(sht1.Range("A1")
sht1.Range("A1").End(xlDown).End(xlToRight))
Set rngSht2 = sht2.Range(sht2.Range("A1")
sht2.Range("A1").End(xlDown).End(xlToRight))

Set destRng = Range("A1")
k = 1

For i = 1 To rngSht1.Rows.Count
If InStr(1, rngSht1(i, 2), "Sport") = 0 Then
Set a = sht2.Range("A:A").Find(rngSht1(i, 2))
If Not a Is Nothing Then
destRng(k, 1) = rngSht1(i, 1)
destRng(k, 2) = rngSht2(a.Row, 2)
destRng(k, 3) = rngSht2(a.Row, 3)
k = k + 1
End If
Else
splCountry = Split(rngSht1(i, 2), "-")
cn = Trim(splCountry(1))
Set b = sht2.Range("B:B").Find(cn)
If Not b Is Nothing Then
For j = 1 To rngSht2.Rows.Count
If Trim(rngSht2(j, 2)) = cn Then
destRng(k, 1) = rngSht1(i, 1)
destRng(k, 2) = rngSht2(j, 2)
destRng(k, 3) = rngSht2(j, 3)
k = k + 1
End If
Next j
End If
End If
Next i

End Sub


(or simply run the above macro by placing it in the sheet3 module).

The output is:

1 UK Football
2 India Cricket
3 UK Football
3 UK Cricket


Note that the Europe part is not handled as it does not know whic
countries to take since the mapping is not available.

Regards

Manges