Hi to all,

I have the following task to do in Excel and am not sure how to
proceed:

I have several dictionary wordlists which I need to merge into one.
They are present in an workbook in Excel 2007 with two worksheets,
respectively named "French" and "German"

The first worksheet "French" contains an EnglishFrench wordlist which
goes like this:

Column A - Column B
aardvark - (n.) oryctérope (masculin)
aardwolf - protèle, petite hyène des savanes australe et orientale,
nocturne qui se nourrit d'insectes et de termites
abaca - (n.) abaque (plante philippine)
.... etc.

The Column A contains an English word and the Column B contains its
French equivalent or some explanation into French.

The second worksheet, named "German", contains an EnglishGerman list
of words - for example:


Column A - Column B
aardvark - (n.) Erdferkel, afrikan. Säugetier
abaca - <textil (musa textilis) * Abakafaser f ; Musafaser f ;
Manilahanf m ; Manilahanffaser f
.... etc.

My task is to merge the two worksheets into a single one (let's call
it "Merged"), containing the English word in Column A, the French
equivalent in Column B, and the German equivalent in Column C -
something like this:

Column A - Column B - Column C
aardvark - (n.) oryctérope (masculin) - (n.) Erdferkel, afrikan.
Säugetier
aardwolf - protèle, petite hyène des savanes australe et orientale,
nocturne qui se nourrit d'insectes et de termites - [empty cell]
abaca - (n.) abaque (plante philippine) - <textil (musa textilis) *
Abakafaser f ; Musafaser f ; Manilahanf m ; Manilahanffaser f
.... etc.

You can see that the EnglishFrench wordlist has an entry for
"aardwolf" whereas there is no such an entry in the EnglishGerman
wordlist. In such cases, the corresponding cell in Column C (for
German) must be left empty. If such a case occurs with a missing
French equivalent, then the corresponding cell in Column B (for
French) will be empty.

Can you help me achieving this task? I don't know if this can be done
by some build-in functionality of Excel 2007 or by means of a custom
macro.

Any idea?

Here is a sample of the file to process: http://rapidshare.com/files/10399603...ists.xlsx.html

Thank you for any help suggested

Hi Ivanov,

This code should do it. I used a collection to compile the list of
unique words as i didn't know how long your list would be. A quicker
method would be to copy one list below the other and use advanced
filter to extract the unique records, but that has a limitation of the
two lists together being no longer than 64K rows in total (in Excel
2003). The collection method negates this.

Sub MergeList()
Dim FrList As Range, DeList As Range, DestList As Range
Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
Set FrList = Sheets("Sheet1").Range("A1")
Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
Set DeList = Sheets("Sheet2").Range("A1")
Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
Set DestList = Sheets("Sheet3").Range("A1")

'Turn off screen refresh & calculation to speed up execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
On Error Resume Next

'Add English words from French list
For Each cell In FrList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next

'Add English words from German list (ignoring duplicates)
For Each cell In DeList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next

'Turn error notification back on
On Error GoTo 0

'Resize destination list to fit total words
Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
i = 1
For Each Item In WordList
DestList.Cells(i) = Item
i = i + 1
Next

'Sort new list alphabetically
DestList.Sort DestList, xlAscending

'Add VLookup formulas for French and German
DestList.Offset(0, 1).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-1],FrList,2,0)),"""",VLOOKUP(RC[-1],FrList,
2,0))"
DestList.Offset(0, 2).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-2],DeList,2,0)),"""",VLOOKUP(RC[-2],DeList,
2,0))"

'Clean up
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

*** Beware of wrapping.

Let me know how you go.

Cheers,
Ivan C.

On Apr 1, 8:21*pm, "
wrote:
Here is a sample of the file to process:http://rapidshare.com/files/10399603...ists.xlsx.html

Thank you for any help suggested

Hmmm,

Just downloaded your book to have a look. I didn't realise the
translation cells had special formatting. This means that the VLookup
formula won't work (well it will, but the result will not be
formatted). This will require two further loops as I see it,
performing the vlookup manually be code.

I'll give it a go.

Other than that, my code seems to do what you want. All I had to do
was change the names of the sheets right at the start.

Cheers,
Ivan.

On Apr 1, 8:58*pm, Ivyleaf wrote:
Hi Ivanov,

This code should do it. I used a collection to compile the list of
unique words as i didn't know how long your list would be. A quicker
method would be to copy one list below the other and use advanced
filter to extract the unique records, but that has a limitation of the
two lists together being no longer than 64K rows in total (in Excel
2003). The collection method negates this.

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("Sheet1").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("Sheet2").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Sheet3").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Add VLookup formulas for French and German
* * DestList.Offset(0, 1).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-1],FrList,2,0)),"""",VLOOKUP(RC[-1],FrList,
2,0))"
* * DestList.Offset(0, 2).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-2],DeList,2,0)),"""",VLOOKUP(RC[-2],DeList,
2,0))"

'Clean up
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub

*** Beware of wrapping.

Let me know how you go.

Cheers,
Ivan C.

On Apr 1, 8:21*pm, "
wrote:



Here is a sample of the file to process:http://rapidshare.com/files/10399603...ists.xlsx.html

Thank you for any help suggested- Hide quoted text -

- Show quoted text -

OK, Try this:

Sub MergeList()
Dim FrList As Range, DeList As Range, DestList As Range
Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
Set FrList = Sheets("French").Range("A1")
Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
Set DeList = Sheets("German").Range("A1")
Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
Set DestList = Sheets("Merged").Range("A1")

'Turn off screen refresh & calculation to speed up execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
On Error Resume Next

'Add English words from French list
For Each cell In FrList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next

'Add English words from German list (ignoring duplicates)
For Each cell In DeList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next

'Turn error notification back on
On Error GoTo 0

'Resize destination list to fit total words
Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
i = 1
For Each Item In WordList
DestList.Cells(i) = Item
i = i + 1
Next

'Sort new list alphabetically
DestList.Sort DestList, xlAscending

'Perform code based VLookup for French and German
On Error Resume Next
For Each cell In DestList.Cells
FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
Err.Clear
FrList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
Err.Clear
Next

'Clean up
With Sheets("Merged")
.Rows("1:1").Insert Shift:=xlDown
.Range("A1:C1") = Array("English", "French", "German")
.Columns.AutoFit
.Rows.AutoFit
.Cells.VerticalAlignment = xlTop
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Cheers,
Ivan.

On Apr 1, 9:03*pm, Ivyleaf wrote:
Hmmm,

Just downloaded your book to have a look. I didn't realise the
translation cells had special formatting. This means that the VLookup
formula won't work (well it will, but the result will not be
formatted). This will require two further loops as I see it,
performing the vlookup manually be code.

I'll give it a go.

Other than that, my code seems to do what you want. All I had to do
was change the names of the sheets right at the start.

Cheers,
Ivan.

On Apr 1, 8:58*pm, Ivyleaf wrote:



Hi Ivanov,

This code should do it. I used a collection to compile the list of
unique words as i didn't know how long your list would be. A quicker
method would be to copy one list below the other and use advanced
filter to extract the unique records, but that has a limitation of the
two lists together being no longer than 64K rows in total (in Excel
2003). The collection method negates this.

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("Sheet1").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("Sheet2").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Sheet3").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Add VLookup formulas for French and German
* * DestList.Offset(0, 1).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-1],FrList,2,0)),"""",VLOOKUP(RC[-1],FrList,
2,0))"
* * DestList.Offset(0, 2).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-2],DeList,2,0)),"""",VLOOKUP(RC[-2],DeList,
2,0))"

'Clean up
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub

*** Beware of wrapping.

Let me know how you go.

Cheers,
Ivan C.

On Apr 1, 8:21*pm, "
wrote:

Here is a sample of the file to process:http://rapidshare.com/files/10399603...ists.xlsx.html

Thank you for any help suggested- Hide quoted text -

- Show quoted text -- Hide quoted text -

- Show quoted text -

Hope I'm not double posting here... my last one didn't seem to work.
Anyway, give this code a try... I reckon it will do the trick:

Sub MergeList()
Dim FrList As Range, DeList As Range, DestList As Range
Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
Set FrList = Sheets("French").Range("A1")
Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
Set DeList = Sheets("German").Range("A1")
Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
Set DestList = Sheets("Merged").Range("A1")

'Turn off screen refresh & calculation to speed up execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
On Error Resume Next

'Add English words from French list
For Each cell In FrList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next

'Add English words from German list (ignoring duplicates)
For Each cell In DeList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next

'Turn error notification back on
On Error GoTo 0

'Resize destination list to fit total words
Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
i = 1
For Each Item In WordList
DestList.Cells(i) = Item
i = i + 1
Next

'Sort new list alphabetically
DestList.Sort DestList, xlAscending

'Perform code based VLookup for French and German
On Error Resume Next
For Each cell In DestList.Cells
FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
Err.Clear
FrList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
Err.Clear
Next

'Clean up
With Sheets("Merged")
.Rows("1:1").Insert Shift:=xlDown
.Range("A1:C1") = Array("English", "French", "German")
.Columns.AutoFit
.Rows.AutoFit
.Cells.VerticalAlignment = xlTop
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub


On Apr 1, 9:03*pm, Ivyleaf wrote:
Hmmm,

Just downloaded your book to have a look. I didn't realise the
translation cells had special formatting. This means that the VLookup
formula won't work (well it will, but the result will not be
formatted). This will require two further loops as I see it,
performing the vlookup manually be code.

I'll give it a go.

Other than that, my code seems to do what you want. All I had to do
was change the names of the sheets right at the start.

Cheers,
Ivan.

On Apr 1, 8:58*pm, Ivyleaf wrote:



Hi Ivanov,

This code should do it. I used a collection to compile the list of
unique words as i didn't know how long your list would be. A quicker
method would be to copy one list below the other and use advanced
filter to extract the unique records, but that has a limitation of the
two lists together being no longer than 64K rows in total (in Excel
2003). The collection method negates this.

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("Sheet1").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("Sheet2").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Sheet3").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Add VLookup formulas for French and German
* * DestList.Offset(0, 1).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-1],FrList,2,0)),"""",VLOOKUP(RC[-1],FrList,
2,0))"
* * DestList.Offset(0, 2).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-2],DeList,2,0)),"""",VLOOKUP(RC[-2],DeList,
2,0))"

'Clean up
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub

*** Beware of wrapping.

Let me know how you go.

Cheers,
Ivan C.

On Apr 1, 8:21*pm, "
wrote:

Here is a sample of the file to process:http://rapidshare.com/files/10399603...ists.xlsx.html

Thank you for any help suggested- Hide quoted text -

- Show quoted text -- Hide quoted text -

- Show quoted text -

Hi Ivyleaf,

Thank you for your helpfulness! I appreciate it.

I tested your last macro. However, the code doesn't process the German
wordlist. The macro copies some French words in the German column of
the Merged worksheet


On Apr 1, 12:27*pm, Ivyleaf wrote:
Hope I'm not double posting here... my last one didn't seem to work.
Anyway, give this code a try... I reckon it will do the trick:

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("French").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("German").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Merged").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Perform code based VLookup for French and German
* * On Error Resume Next
* * For Each cell In DestList.Cells
* * * * FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
* * * * If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
* * * * Err.Clear
* * * * FrList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
* * * * If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
* * * * Err.Clear
* * Next

'Clean up
* * With Sheets("Merged")
* * * * .Rows("1:1").Insert Shift:=xlDown
* * * * .Range("A1:C1") = Array("English", "French", "German")
* * * * .Columns.AutoFit
* * * * .Rows.AutoFit
* * * * .Cells.VerticalAlignment = xlTop
* * End With
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub

On Apr 1, 9:03*pm, Ivyleaf wrote:



Hmmm,

Just downloaded your book to have a look. I didn't realise the
translation cells had special formatting. This means that the VLookup
formula won't work (well it will, but the result will not be
formatted). This will require two further loops as I see it,
performing the vlookup manually be code.

I'll give it a go.

Other than that, my code seems to do what you want. All I had to do
was change the names of the sheets right at the start.

Cheers,
Ivan.

On Apr 1, 8:58*pm, Ivyleaf wrote:

Hi Ivanov,

This code should do it. I used a collection to compile the list of
unique words as i didn't know how long your list would be. A quicker
method would be to copy one list below the other and use advanced
filter to extract the unique records, but that has a limitation of the
two lists together being no longer than 64K rows in total (in Excel
2003). The collection method negates this.

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("Sheet1").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("Sheet2").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Sheet3").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Add VLookup formulas for French and German
* * DestList.Offset(0, 1).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-1],FrList,2,0)),"""",VLOOKUP(RC[-1],FrList,
2,0))"
* * DestList.Offset(0, 2).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-2],DeList,2,0)),"""",VLOOKUP(RC[-2],DeList,
2,0))"

'Clean up
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub

*** Beware of wrapping.

Let me know how you go.

Cheers,
Ivan C.

On Apr 1, 8:21*pm, "
wrote:

Here is a sample of the file to process:http://rapidshare.com/files/10399603...ists.xlsx.html

Thank you for any help suggested- Hide quoted text -

- Show quoted text -- Hide quoted text -

- Show quoted text -- Hide quoted text -

- Show quoted text -

Hi Ivanov,

I think I found the problem... a simple two letter typo (well actually
copy and paste mistake).

In the section where it is performing the code based lookup (right at
the end), it first looks at the French List, then when it is supposed
to be looking at the German list, I forgot to change the range name so
it is looking at the French list again.

Change:

'Perform code based VLookup for French and German
On Error Resume Next
For Each cell In DestList.Cells
FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
Err.Clear
FrList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
Err.Clear
Next

to:

'Perform code based VLookup for French and German
On Error Resume Next
For Each cell In DestList.Cells
FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
Err.Clear
DeList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
Err.Clear
Next

and you should be fine.

Cheers,
Ivan.

On Apr 1, 9:54*pm, "
wrote:
Hi Ivyleaf,

Thank you for your helpfulness! I appreciate it.

I tested your last macro. However, the code doesn't process the German
wordlist. The macro copies some French words in the German column of
the Merged worksheet

On Apr 1, 12:27*pm, Ivyleaf wrote:



Hope I'm not double posting here... my last one didn't seem to work.
Anyway, give this code a try... I reckon it will do the trick:

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("French").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("German").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Merged").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Perform code based VLookup for French and German
* * On Error Resume Next
* * For Each cell In DestList.Cells
* * * * FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
* * * * If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
* * * * Err.Clear
* * * * FrList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
* * * * If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
* * * * Err.Clear
* * Next

'Clean up
* * With Sheets("Merged")
* * * * .Rows("1:1").Insert Shift:=xlDown
* * * * .Range("A1:C1") = Array("English", "French", "German")
* * * * .Columns.AutoFit
* * * * .Rows.AutoFit
* * * * .Cells.VerticalAlignment = xlTop
* * End With
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub

On Apr 1, 9:03*pm, Ivyleaf wrote:

Hmmm,

Just downloaded your book to have a look. I didn't realise the
translation cells had special formatting. This means that the VLookup
formula won't work (well it will, but the result will not be
formatted). This will require two further loops as I see it,
performing the vlookup manually be code.

I'll give it a go.

Other than that, my code seems to do what you want. All I had to do
was change the names of the sheets right at the start.

Cheers,
Ivan.

On Apr 1, 8:58*pm, Ivyleaf wrote:

Hi Ivanov,

This code should do it. I used a collection to compile the list of
unique words as i didn't know how long your list would be. A quicker
method would be to copy one list below the other and use advanced
filter to extract the unique records, but that has a limitation of the
two lists together being no longer than 64K rows in total (in Excel
2003). The collection method negates this.

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("Sheet1").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("Sheet2").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Sheet3").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Add VLookup formulas for French and German
* * DestList.Offset(0, 1).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-1],FrList,2,0)),"""",VLOOKUP(RC[-1],FrList,
2,0))"
* * DestList.Offset(0, 2).FormulaR1C1 =
"=IF(ISERROR(VLOOKUP(RC[-2],DeList,2,0)),"""",VLOOKUP(RC[-2],DeList,
2,0))"

'Clean up
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub

*** Beware of wrapping.

Let me know how you go.

Cheers,
Ivan C.

On Apr 1, 8:21*pm, "
wrote:

Here is a sample of the file to process:http://rapidshare.com/files/10399603...ists.xlsx.html

Thank you for any help suggested- Hide quoted text -

- Show quoted text -- Hide quoted text -

- Show quoted text -- Hide quoted text -

- Show quoted text -- Hide quoted text -

- Show quoted text -

Hi Ivyleaf,

Now the macro works like charm! Thank you very much for your help.

You rule!

And here is the final macro for someone else who may need it:

Sub MergeList()
Dim FrList As Range, DeList As Range, DestList As Range
Dim cell As Range, WordList As New Collection, i As Integer


'This sets the range of the French list
Set FrList = Sheets("French").Range("A1")
Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"


'This sets the range of the German list
Set DeList = Sheets("German").Range("A1")
Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"


'This sets the range of the new destination list
Set DestList = Sheets("Merged").Range("A1")


'Turn off screen refresh & calculation to speed up execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'Error handling for when the program attempts to add
'the same word to the collection twice
On Error Resume Next


'Add English words from French list
For Each cell In FrList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next


'Add English words from German list (ignoring duplicates)
For Each cell In DeList.Cells
If Not IsEmpty(cell) Then
WordList.Add cell.Value, CStr(cell.Value)
End If
Next


'Turn error notification back on
On Error GoTo 0


'Resize destination list to fit total words
Set DestList = DestList.Resize(WordList.Count, 1)


'Loop to put words to new list
i = 1
For Each Item In WordList
DestList.Cells(i) = Item
i = i + 1
Next


'Sort new list alphabetically
DestList.Sort DestList, xlAscending


'Perform code based VLookup for French and German
On Error Resume Next
For Each cell In DestList.Cells
FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
Err.Clear
DeList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
Err.Clear
Next


'Clean up
With Sheets("Merged")
.Rows("1:1").Insert Shift:=xlDown
.Range("A1:C1") = Array("English", "French", "German")
.Columns.AutoFit
.Rows.AutoFit
.Cells.VerticalAlignment = xlTop
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

Hi Ivanov,

Very good to hear and thanks for the feedback. Us Ivan's have to stick
together :)

Cheers,

On Apr 2, 1:47*am, "
wrote:
Hi Ivyleaf,

Now the macro works like charm! Thank you very much for your help.

You rule!

And here is the final macro for someone else who may need it:

Sub MergeList()
* * Dim FrList As Range, DeList As Range, DestList As Range
* * Dim cell As Range, WordList As New Collection, i As Integer

'This sets the range of the French list
* * Set FrList = Sheets("French").Range("A1")
* * Set FrList = Range(FrList, FrList.Range("A65536").End(xlUp))
* * FrList.Resize(FrList.Rows.Count, 2).Name = "FrList"

'This sets the range of the German list
* * Set DeList = Sheets("German").Range("A1")
* * Set DeList = Range(DeList, DeList.Range("A65536").End(xlUp))
* * DeList.Resize(DeList.Rows.Count, 2).Name = "DeList"

'This sets the range of the new destination list
* * Set DestList = Sheets("Merged").Range("A1")

'Turn off screen refresh & calculation to speed up execution
* * Application.ScreenUpdating = False
* * Application.Calculation = xlCalculationManual

'Error handling for when the program attempts to add
'the same word to the collection twice
* * On Error Resume Next

'Add English words from French list
* * * * For Each cell In FrList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Add English words from German list (ignoring duplicates)
* * * * For Each cell In DeList.Cells
* * * * * * If Not IsEmpty(cell) Then
* * * * * * WordList.Add cell.Value, CStr(cell.Value)
* * * * * * End If
* * * * Next

'Turn error notification back on
* * On Error GoTo 0

'Resize destination list to fit total words
* * Set DestList = DestList.Resize(WordList.Count, 1)

'Loop to put words to new list
* * i = 1
* * For Each Item In WordList
* * * * DestList.Cells(i) = Item
* * * * i = i + 1
* * Next

'Sort new list alphabetically
* * DestList.Sort DestList, xlAscending

'Perform code based VLookup for French and German
* * On Error Resume Next
* * For Each cell In DestList.Cells
* * * * FrList.Cells(Application.Match(cell.Value, FrList,
0)).Offset(0, 1).Copy
* * * * If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 1)
* * * * Err.Clear
* * * * DeList.Cells(Application.Match(cell.Value, DeList,
0)).Offset(0, 1).Copy
* * * * If Err.Number = 0 Then Sheets("Merged").Paste
Destination:=cell.Offset(0, 2)
* * * * Err.Clear
* * Next

'Clean up
* * With Sheets("Merged")
* * * * .Rows("1:1").Insert Shift:=xlDown
* * * * .Range("A1:C1") = Array("English", "French", "German")
* * * * .Columns.AutoFit
* * * * .Rows.AutoFit
* * * * .Cells.VerticalAlignment = xlTop
* * End With
* * Application.ScreenUpdating = True
* * Application.Calculation = xlCalculationAutomatic

End Sub