Can you help me to improve this macro?

[Dario de Judicibus]

I would like some help to improve the following macro (I am NOT an Excel
programmer). The macro simply invert a sheet where column 1 is for terms and
columns 2-n are for translations. I would like

1. to move the temporary range to another sheet, to avoid overlap between
temporary range and current one
2. improve performances

Any hints appreciated. Thank you in advance.

--
Dario de Judicibus - Rome, Italy (EU)
Site: http://www.dejudicibus.it
Blog: http://lindipendente.splinder.com

MACRO
Public Sub ReverseDictionary()
Set tr = ActiveSheet.UsedRange
Debug.Print tr.Rows.Count
Debug.Print tr.Columns.Count
Set newlist = Cells(1, tr.Columns.Count + 2) 'Temporary range
newrow = 0
For n = 1 To tr.Rows.Count
head = tr.Cells(n, 1)
c = 2
While Not IsEmpty(tr.Cells(n, c))
newrow = newrow + 1
newlist.Cells(newrow, 1).NumberFormat = "@"
newlist.Cells(newrow, 2).NumberFormat = "@"
newlist.Cells(newrow, 1) = head
newlist.Cells(newrow, 2) = tr.Cells(n, c)
c = c + 1
Wend
Next
Range(newlist, newlist.Cells(newrow, 2)).Sort Key1:=newlist.Cells(1, 2),
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
tr.Clear
outrow = 0
head = ""
For n = 1 To newrow
If head = newlist(n, 2) Then
outcol = outcol + 1
tr.Cells(outrow, 1).NumberFormat = "@"
tr.Cells(outrow, outcol).NumberFormat = "@"
tr.Cells(outrow, 1) = head
tr.Cells(outrow, outcol) = newlist(n, 1)
Else
outcol = 1
outrow = outrow + 1
head = newlist(n, 2)
n = n - 1
End If
Next
Range(newlist, newlist.Cells(newrow, 2)).Clear

End Sub

 

[Jim Cone]

Dario,

The following ought to be close to what you want
and it certainly is simpler. Does it do what you wanted?

'--------------------------------
Sub ReverseDirectory_New()
Application.ScreenUpdating = False
Columns("D:E").Insert shift:=xlShiftToRight
Columns("D:E").Value = Columns("A:B").Value
Columns("A").Value = Columns("E").Value
Columns("B").Value = Columns("D").Value
Application.ScreenUpdating = True
End Sub
'--------------------------------------

Regards,
Jim Cone
San Francisco, USA


message I would like some help to improve the following macro (I am NOT an Excel
programmer). The macro simply invert a sheet where column 1 is for terms and
columns 2-n are for translations. I would like
1. to move the temporary range to another sheet, to avoid overlap between
temporary range and current one
2. improve performances
Any hints appreciated. Thank you in advance.
--
Dario de Judicibus - Rome, Italy (EU)
Site: http://www.dejudicibus.it
Blog: http://lindipendente.splinder.com

MACRO
Public Sub ReverseDictionary()
Set tr = ActiveSheet.UsedRange
Debug.Print tr.Rows.Count
Debug.Print tr.Columns.Count
Set newlist = Cells(1, tr.Columns.Count + 2) 'Temporary range
newrow = 0
For n = 1 To tr.Rows.Count
head = tr.Cells(n, 1)
c = 2
While Not IsEmpty(tr.Cells(n, c))
newrow = newrow + 1
newlist.Cells(newrow, 1).NumberFormat = "@"
newlist.Cells(newrow, 2).NumberFormat = "@"
newlist.Cells(newrow, 1) = head
newlist.Cells(newrow, 2) = tr.Cells(n, c)
c = c + 1
Wend
Next
Range(newlist, newlist.Cells(newrow, 2)).Sort Key1:=newlist.Cells(1, 2),
Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
tr.Clear
outrow = 0
head = ""
For n = 1 To newrow
If head = newlist(n, 2) Then
outcol = outcol + 1
tr.Cells(outrow, 1).NumberFormat = "@"
tr.Cells(outrow, outcol).NumberFormat = "@"
tr.Cells(outrow, 1) = head
tr.Cells(outrow, outcol) = newlist(n, 1)
Else
outcol = 1
outrow = outrow + 1
head = newlist(n, 2)
n = n - 1
End If
Next
Range(newlist, newlist.Cells(newrow, 2)).Clear
End Sub

 

[Dario de Judicibus]

Dario,

The following ought to be close to what you want
and it certainly is simpler. Does it do what you wanted?

'--------------------------------
Sub ReverseDirectory_New()
Application.ScreenUpdating = False
Columns("D:E").Insert shift:=xlShiftToRight
Columns("D:E").Value = Columns("A:B").Value
Columns("A").Value = Columns("E").Value
Columns("B").Value = Columns("D").Value
Application.ScreenUpdating = True
End Sub
'--------------------------------------

Apart screen updating (good idea to disable it - I did not know it was
possible), I am not sure that your code does what I need. Let me clarify:

I have a sheet where column A contains terms. Columns B to <any> may contain
one or more translations. For example

| home | casa | abitazione | focolare |
| house | casa | costruzione |
| building | edificio | costruzione |

now, I need to reverse dictionary

| abitazione | home |
| casa | home | house |
| costruzione | house | building |
| edificio | building |
| focolare | home |

note that every record has different length in terms of columns. The macro I
published (made by a kind excel programmer) is good, but too slow for big
dictionaries and furthermore it uses the SAME worksheet for temporary stuff
(it works in two steps). Is it possible to use a temporary sheet and improve
performances?

Thank you in advance.

Dario de Judicibus

 

[Jim Cone]

Dario,

It's a tricky little devil - I did clean it up a little
and the reversed list goes on a new sheet.
It ought to be closer to what you want.
'--------------------------------------------------
Option Explicit

Public Sub ReverseDictionary()
'Modified by Jim Cone - San Francisco, USA on June 14, 2005
'to add a new worksheet to contain the reversed dictionary.
On Error GoTo ErrHandler
Dim rngOriginal As Excel.Range
Dim rngTop As Excel.Range
Dim wsNew As Excel.Worksheet
Dim NewRow As Long
Dim OutRow As Long
Dim OutCol As Long
Dim n As Long
Dim c As Long
Dim Head As Variant

Set rngOriginal = ActiveSheet.UsedRange
'Debug.Print rngOriginal.Rows.Count
'Debug.Print rngOriginal.Columns.Count
Set wsNew = Worksheets.Add(before:=ActiveSheet, Count:=1)
On Error Resume Next
wsNew.Name = "Reversed " & Format$(Date, "ddmmyy")
On Error GoTo ErrHandler
Set rngTop = wsNew.Cells(1, rngOriginal.Columns.Count + 2)
Application.ScreenUpdating = False

For n = 1 To rngOriginal.Rows.Count
Head = rngOriginal(n, 1).Value
c = 2
While Not IsEmpty(rngOriginal(n, c))
NewRow = NewRow + 1
rngTop(NewRow, 1).NumberFormat = "@"
rngTop(NewRow, 2).NumberFormat = "@"
rngTop(NewRow, 1) = Head
rngTop(NewRow, 2).Value = rngOriginal(n, c).Value
c = c + 1
Wend
Next

Range(rngTop, rngTop(NewRow, 2)).Sort Key1:=rngTop(1, 2), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
OutRow = 0
Head = ""

For n = 1 To NewRow
If Head = rngTop(n, 2) Then
OutCol = OutCol + 1
wsNew.Range(rngOriginal.Address)(OutRow, 1).NumberFormat = "@"
wsNew.Range(rngOriginal.Address)(OutRow, OutCol).NumberFormat = "@"
wsNew.Range(rngOriginal.Address)(OutRow, 1) = Head
wsNew.Range(rngOriginal.Address)(OutRow, OutCol) = rngTop(n, 1)
Else
OutCol = 1
OutRow = OutRow + 1
Head = rngTop(n, 2)
n = n - 1
End If
Next
Range(rngTop, rngTop(NewRow, 2)).ClearContents
ExitProcess:

Application.ScreenUpdating = True
Set rngOriginal = Nothing
Set rngTop = Nothing
Set wsNew = Nothing
Exit Sub

ErrHandler:
Beep
Resume ExitProcess
End Sub
'----------------------------


----- Original Message -----
From: "Dario de Judicibus" <[email protected]>
Newsgroups: microsoft.public.excel.programming
Sent: Tuesday, June 14, 2005 5:11 AM
Subject: Re: Can you help me to improve this macro?

Dario,
The following ought to be close to what you want
and it certainly is simpler. Does it do what you wanted?
'--------------------------------
Sub ReverseDirectory_New()
Application.ScreenUpdating = False
Columns("D:E").Insert shift:=xlShiftToRight
Columns("D:E").Value = Columns("A:B").Value
Columns("A").Value = Columns("E").Value
Columns("B").Value = Columns("D").Value
Application.ScreenUpdating = True
End Sub
'--------------------------------------

Apart screen updating (good idea to disable it - I did not know it was
possible), I am not sure that your code does what I need. Let me clarify:
I have a sheet where column A contains terms. Columns B to <any> may contain
one or more translations. For example

| home | casa | abitazione | focolare |
| house | casa | costruzione |
| building | edificio | costruzione |

now, I need to reverse dictionary

| abitazione | home |
| casa | home | house |
| costruzione | house | building |
| edificio | building |
| focolare | home |

note that every record has different length in terms of columns. The macro I
published (made by a kind excel programmer) is good, but too slow for big
dictionaries and furthermore it uses the SAME worksheet for temporary stuff
(it works in two steps). Is it possible to use a temporary sheet and improve
performances?
Thank you in advance.
Dario de Judicibus

 

[Dario de Judicibus]

Thank you very much. I'll try it soon!!!!

DdJ

 

[Dario de Judicibus]

WORKS FINE! Thank you, Jim.

DdJ