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 -