Merging wordsheets in Excel 2007

[ivanov.ivaylo]

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 English>French 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 English>German 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 English>French wordlist has an entry for
"aardwolf" whereas there is no such an entry in the English>German
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?

 

[ivanov.ivaylo]

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

Thank you for any help suggested

 

[Ivyleaf]

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.

 

[Ivyleaf]

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.

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.

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

Thank you for any help suggested- Hide quoted text -

- Show quoted text -

 

[Ivyleaf]

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.

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.

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, "(e-mail address removed)" <[email protected]>
wrote:

- Show quoted text -- Hide quoted text -

- Show quoted text -

 

[Ivyleaf]

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

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.

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, "(e-mail address removed)" <[email protected]>
wrote:

- Show quoted text -- Hide quoted text -

- Show quoted text -

 

[ivanov.ivaylo]

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

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

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.

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, "(e-mail address removed)" <[email protected]>
wrote:
Here is a sample of the file to process:http://rapidshare.com/files/103996032/wordlists.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 -

 

[Ivyleaf]

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.

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

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

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.
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, "(e-mail address removed)" <[email protected]>
wrote:
Here is a sample of the file to process:http://rapidshare.com/files/103996032/wordlists.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 -

 

[ivanov.ivaylo]

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

 

[Ivyleaf]

Hi Ivanov,

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

Cheers,