Solved: Speeding up routine

[tuxy]

First of all , congratulations for this top programming forum , and sorry if my english is not so clear , anyway I go straight to the point: I have the following routine (part of the code was picked up from this forum)that I use to compare two different column and for reporting (if values matches) the value in the first range under a specific column .
The problem is:

1) Is it possible to speed-up the code (basically I compare column with 4000-8000 records) It takes too long.
2) it could happen that one of the two columns need to be trimmed but in this case trim seems not working.Why?
3) Is It possible to set a sort of progressive bar or something like that (point 3 is not really important)to see the status.
I have not so much experience in VBA (sorry) , here is the code:


Sub Mousepare()



Const strTitleSelectRange_c As String = "Select Range"
Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Dim cella As Object
Dim cella2 As Object
Dim C As String
Dim R As Integer
Dim c1r As Integer
Dim c2r As Integer
Dim c1c As Integer
Dim c2c As Integer
Dim tot As Integer


' Definisci i range
Set rng1 = GetRange("Select range n?1 with mouse:", strTitleSelectRange_c)
Set rng2 = GetRange("Select range n?2 with mouse :", strTitleSelectRange_c)
R = InputBox("Select offset (number value) to report:")
C = InputBox("Select column where report the value:")
contatore = 1
For Each cella In rng1
For Each cella2 In rng2


Trim (cella.Value)
Trim (cella2.Value)
c1r = cella.Row
c2r = cella2.Row
'c1c = cella.Column
'c2c = cella.Column





If cella2 = cella Then
'Range(C & c1r).Value = cella2.Offset(0, 1).Value
Range(C & c1r).Value = cella2.Offset(0, R).Value

End If
contatore = contatore + 1
Next cella2
Next cella


End Sub
Private Function GetRange(Prompt As String, Title As String) As Excel.Range
On Error Resume Next
Const lngRange_c As Long = 8
Set GetRange = Excel.Application.InputBox(Prompt, Title, Type:=lngRange_c)
End Function

Best Regards
Tuxy(Italy)

[Bob Phillips]

A couple of thoughts


Sub Mousepare()
Const strTitleSelectRange_c As String = "Select Range"
Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Dim cella As Object
Dim cella2 As Object
Dim C As String
Dim R As Integer
Dim c1r As Integer
Dim c2r As Integer
Dim c1c As Integer
Dim c2c As Integer
Dim tot As Integer

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

' Definisci i range
Set rng1 = GetRange("Select range n?1 with mouse:", strTitleSelectRange_c)
Set rng2 = GetRange("Select range n?2 with mouse :", strTitleSelectRange_c)
R = InputBox("Select offset (number value) to report:")
C = InputBox("Select column where report the value:")
contatore = 1
For Each cella In rng1

For Each cella2 In rng2

Trim (cella.Value)
cella.Value = Replace(cella.Value, Chr(160), "")
Trim (cella2.Value)
cella2.Value = Replace(cella2.Value, Chr(160), "")
c1r = cella.Row
c2r = cella2.Row
'c1c = cella.Column
'c2c = cella.Column

If cella2 = cella Then

'Range(C & c1r).Value = cella2.Offset(0, 1).Value
Range(C & c1r).Value = cella2.Offset(0, R).Value
End If

contatore = contatore + 1
Next cella2
Next cella

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub
Private Function GetRange(Prompt As String, Title As String) As Excel.Range
On Error Resume Next
Const lngRange_c As Long = 8
Set GetRange = Excel.Application.InputBox(Prompt, Title, Type:=lngRange_c)
End Function

[tuxy]

A couple of thoughts


Sub Mousepare()
Const strTitleSelectRange_c As String = "Select Range"
Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Dim cella As Object
Dim cella2 As Object
Dim C As String
Dim R As Integer
Dim c1r As Integer
Dim c2r As Integer
Dim c1c As Integer
Dim c2c As Integer
Dim tot As Integer

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

' Definisci i range
Set rng1 = GetRange("Select range n?1 with mouse:", strTitleSelectRange_c)
Set rng2 = GetRange("Select range n?2 with mouse :", strTitleSelectRange_c)
R = InputBox("Select offset (number value) to report:")
C = InputBox("Select column where report the value:")
contatore = 1
For Each cella In rng1

For Each cella2 In rng2

Trim (cella.Value)
cella.Value = Replace(cella.Value, Chr(160), "")
Trim (cella2.Value)
cella2.Value = Replace(cella2.Value, Chr(160), "")
c1r = cella.Row
c2r = cella2.Row
'c1c = cella.Column
'c2c = cella.Column

If cella2 = cella Then

'Range(C & c1r).Value = cella2.Offset(0, 1).Value
Range(C & c1r).Value = cella2.Offset(0, R).Value
End If

contatore = contatore + 1
Next cella2
Next cella

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub
Private Function GetRange(Prompt As String, Title As String) As Excel.Range
On Error Resume Next
Const lngRange_c As Long = 8
Set GetRange = Excel.Application.InputBox(Prompt, Title, Type:=lngRange_c)
End Function

First of all thank you for your help.

I had to disable this part of the code because it' impossible to select range using the mouse:
With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Trim is not working if I compare a column with the value = A with another with value = space A match is skipped and the corrisponding value is not reported.
But the main problem remains the same too , too slow.

Best Regards.
Roberto

[rbrhodes]

Hi tuxy,

I moved the screen and calculation lines so they will work for you.

and changed the 'Trim' Statements



Sub Mousepare()
Const strTitleSelectRange_c As String = "Select Range"
Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Dim cella As Object
Dim cella2 As Object
Dim C As String
Dim R As Integer
Dim c1r As Integer
Dim c2r As Integer
Dim c1c As Integer
Dim c2c As Integer
Dim tot As Integer


' Definisci i range
Set rng1 = GetRange("Select range n?1 with mouse:", strTitleSelectRange_c)
Set rng2 = GetRange("Select range n?2 with mouse :", strTitleSelectRange_c)
R = InputBox("Select offset (number value) to report:")
C = InputBox("Select column where report the value:")
contatore = 1


'//MOVED TO HERE to allow for mouse selection

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

'//Do global replace
rng1.Replace What:=Chr(160), Replacement:=""
rng2.Replace What:=Chr(160), Replacement:=""

For Each cella In rng1
'//Do once
cella = Trim (cella)

For Each cella2 In rng2

cella2 = Trim (cella2)
c1r = cella.Row
c2r = cella2.Row
'c1c = cella.Column
'c2c = cella.Column

If cella2 = cella Then

'Range(C & c1r).Value = cella2.Offset(0, 1).Value
Range(C & c1r).Value = cella2.Offset(0, R).Value
End If

contatore = contatore + 1
Next cella2
Next cella

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

[tuxy]

Thak you very much , I'll try it , in the meanwhile I modified the code as follow

Private Sub CommandButton1_Click()

' Definisco le variabili
Const strTitleSelectRange_c As String = "Select Range"
Dim rng1 As Excel.Range
Dim rng2 As Excel.Range
Dim cella As Object
Dim cella2 As Object
Dim C As String
Dim R As Integer
Dim c1r As Integer
Dim c2r As Integer
Dim c1c As Integer
Dim c2c As Integer
' Definisci i range
Set rng1 = GetRange("Selezionare con il mouse il primo range di ricerca:", strTitleSelectRange_c)
Set rng2 = GetRange("Selezionare con il mouse il secondo range di ricerca:", strTitleSelectRange_c)
R = InputBox("Indicare Colonna (valore numerico) da riportare:")
C = InputBox("Indicare Colonna sotto cui riportare il dato:")
'For Each cella In rng1
''For Each cella2 In rng2
'Trim (cella.Value)
'Trim (cella2.Value)
'c1r = cella.Row
'c2r = cella2.Row
'c1c = cella.Column
'c2c = cella.Column
For Each cella In rng1
For Each cella2 In rng2
If Application.CountIf(rng2, Trim(cella.Value)) > 0 Then
c1r = cella.Row

'Cells(CL.Row, C).Value = "OK"
'Else
'Cells(CL.Row, C).Value = "NO in " & NF2
'End If
'Next
'If cella2 = cella Then
'Range(C & c1r).Value = cella2.Offset(0, 1).Value
'Range(C & c1r).Value = cella2.Offset(0, R).Value
'my problem is here I can get the different ‘value of the matching but only the first one
Range(C & c1r).Value = rng2.Cells.Offset(0, R).Value
End If

Next cella2

Next cella
End Sub
Private Function GetRange(Prompt As String, Title As String) As Excel.Range
On Error Resume Next
Const lngRange_c As Long = 8
Set GetRange = Excel.Application.InputBox(Prompt, Title, Type:=lngRange_c)
End Function


Now the routine is faster and faster but I can get the right value but only the first one , am I on the right path? It seems to me that the istruction If application.count could be the solution for real speeding up
This forum is amazing and also the people around it

[rbrhodes]

Hi tuxy.

Why not post a small sample workbook so we can see just what it is you're trying to do. I can't figure it out...

[mdmackillop]

Hi Tuxy,
When you post code, select it and click the VBA button to format it as shown. I makes it more readable

[tuxy]

Here is an example of what I'm going to do:

1)launch macro1
2)select first range (sheet "a")
3)select 2? range (sheet "b")
4)input 1 when prompted
5)input column B or C........

I also set a progressive bar into the status bar (please set status bar as visible)

Best Regards
Thank you very much for your cooperation

[rbrhodes]

Hi tuxy,

I think I understand now. You want to select Sheet A value, compare it to Sheet 2 value and if a match is found copy the offset value to Sheet 1. Is that correct?

I ran your code and it completed in 4:57

I updated it with Screenupdating turned off and it completed in 3:45 ( a savings of a whopping 1:12)

I rewrote the code and it runs in 00:03.


NOTE: Your code has no routine to handle duplicates. So I assume the codes will ALWAYS be unique. If dupes exist, your code will overwrite the first value with the next, etc until only the last value is displayed.

I did not provide any code to handle dupes, either...

[tuxy]

Rbrhodes , you did it!!!!!!! , congratulations..................amazing job
THANK YOU ,
YOU ARE GREAT!!!!!!!!!!!:clap::clap::clap::clap::clap::clap::clap::clap::clap::clap ::clap::clap::clap::clap::clap::clap::clap::clap:

[rbrhodes]

You're welcome!

dr