this code is VERY slow, is it the code or perhaps a worksheet issue

[Howard]

Excel 2010

When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.

The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column, same slowness with cut and paste of 150 to 250 entries in a column to another column.

The sheets data is about 50 columns by 300 rows and a "storage column" justover 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.

I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part ofthe cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???

Any ideas?

Option Explicit
Sub CopyLeft()
'activecell must start row 1 to row 16 of column

Dim c As Range
Dim j As Integer
ActiveCell.End(xlDown).Select

j = ActiveCell.End(xlDown).Row
ActiveCell.Resize(j - 16, 1).Select

With Selection
For Each c In Selection
If c.Offset(0, -1).Value = "X" Then
c.Resize(1, 2).Cut c.Offset(0, -2)
End If
Next
End With

End Sub

Thanks.
Regards,
Howard

 

[joeu2004]

Excel 2010
When I run this code it takes a tiny bit less than
one second for each entry with no "X" in the column
to the left and at least a full second if it has to
cut & paste the resized cells in response to the "X"
in the column to the left.
The worksheet also seems to be slower than normal using
common sheet procedures like selecting a couple of cells
and draging them to another column, same slowness with
cut and paste of 150 to 250 entries in a column to another
column.
The sheets data is about 50 columns by 300 rows and a
"storage column" just over 1000 rows.

From your description, the problem is not where the size of the "used range"
in the worksheet. Instead, I suspect it is due to a large number of
"volatile" formulas (or dependencies on them) and/or the use of full-column
ranges like A:A.

Those issues should be addressed. But there are a number of things that you
can do to improve the run-time of the macro, despite those issues.

At a minimum, you should disable ScreenUpdating and set Manual calculation
mode. If you have any event macros, you might want to disable events as
well.

Try this (note also the change in Dim j):

Option Explicit
Sub CopyLeft()
'activecell must start row 1 to row 16 of column
Dim c As Range
Dim j As Long ' *** unrelated improvement ***
Dim st as Double ' *** debug ***
st = Timer ' *** debug ***
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
ActiveCell.End(xlDown).Select
j = ActiveCell.End(xlDown).Row
ActiveCell.Resize(j - 16, 1).Select
With Selection
For Each c In Selection
If c.Offset(0, -1).Value = "X" Then
c.Resize(1, 2).Cut c.Offset(0, -2)
End If
Next
End With
' *** execute these statements in Immed Window ***
' *** if macro should abort for any reason ***
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
' *** Timer-st is not valid across midnight ***
MsgBox Format(Timer - st, "0.000") & " sec" ' *** debug ***
End Sub

 

[Howard]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

Hi joeu2004,

Thanks for the response. I tried your amended code on a 45 row sample withan X on every other row. Timer was 18.5 seconds, which I'm guessing is pretty close to my orignal code.

To add, there are no formulas on this sheet or in the workbook and ALL the data I'm working with in on one sheet. The maximun depth of most columns is around 300 to 400 rows and one column about 1500 rows.

Since this is a "one-time-project" I can live with snail pace given that the code does exactly what I want it to do... this is a hobby project not a "at work commercial" endeavor.

I appreciate the help and will arcive your code suggestion. Stuff like that is good to have around for reference for novice coders like myself.

Thanks again.

Regards,
Howard

 

[Don Guillett]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

I'm curious. What is your excel version? send me the before file and macros..

 

[GS]

<IMO>
I'm pretty sure the fastest way to handle this is to 'dump' the entire
usedRange into an array, work the array as desired, then 'dump' the
results back into the worksheet.

I base this on the fact that your code reads/writes the worksheet for
each iteration. Also, you spend tonnes of time selecting things that
don't need to be selected, but could be worked on directly if you need
to read/write the worksheet.

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Howard]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

Hi Gary.

Have to admitt I am completely lost to... 'dump' the entire
usedRange into an array, work the array as desired etc... and also on the read/write iteration issuse.

I understand the desirability to eliminate selecting whenever you can, for me it usually comes down to not being able to write more elegant code.

I do appreciate you input and suggestions.

Regards,
Howard

 

[GS]

Try this...

Assumes ColA contains "X" in some rows; Cols B/C contain data that will
be shifted to Cols A/B if colA contains "X". (Modify to suit your
layout)

Sub CopyLeft()
Dim rng As Range, lRow As Long
Const NumRows As Long = 16 '//edit size as required

'Range to be checked is from row1 to resize constant above,
'where the active cell is in row1/column1 of the data to shift.
Set rng = ActiveCell.Resize(NumRows)

For lRow = 1 To rng.Rows.Count
With rng
With .Cells(lRow)
If .Offset(0, -1).Value = "X" Then _
.Resize(1, 2).Cut .Offset(0, -1)
End With '.Cells(lRow)
End With 'rng
Next 'lRow
End Sub 'CopyLeft()

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Howard]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

Thanks Garry,

I will give it a go. I do see some code in your suggestion I was trying toincorporate but I usually need examples from script like yours to get the syntax correct.

Thanks again.
Howard

 

[Howard]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

 

[Howard]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit



Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

Garry,

I tried your code and it works fine. I timed it using a house clock with asweep hand and it took about 35 seconds to do 283 rows. I installed a coded timer I got from one other contributor into your code and it read out 29..9 seconds for the same 283 rows. Seems a bit slow but I will live with it..

Currently I am manually putting the X's in the adjacent column where I wantdata moved. That is to say I put the X in column A whenever column be is shaded light red. The red shade is from conditional formatting and indicates a duplicate. Is there a way run some code on column B and if the cell is shaded light red, it puts an X in column A? Seems to me conditional formatting colors elusive to code like that. But it would be a huge time saverif that could be done with code.

Thanks for you time and suggestions.
Regards,
Howard

 

[Claus Busch]

Hi Howard,

Am Sun, 7 Oct 2012 00:59:00 -0700 (PDT) schrieb Howard:

Currently I am manually putting the X's in the adjacent column where I want data moved. That is to say I put the X in column A whenever column be is shaded light red. The red shade is from conditional formatting and indicates a duplicate. Is there a way run some code on column B and if the cell is shaded light red, it puts an X in column A? Seems to me conditional formatting colors elusive to code like that. But it would be a huge time saver if that could be done with code.

please post your formula for condition format.


Regards
Claus Busch

 

[joeu2004]

Garry,
I tried your code and it works fine.

I'm surprised to see you say that. It does not have the functionality that
your implementation does.

In particular, your original implementation seems to assume that an empty
cell above the data is selected. Your code was:


'activecell must start row 1 to row 16 of column
[....]
ActiveCell.End(xlDown).Select
j = ActiveCell.End(xlDown).Row
ActiveCell.Resize(j - 16, 1).Select


But that implementation is flawed unless that data starts in row 17. If
not, Resize(j-16,1) specifies more than the number of rows in the table.
How much more depends on where the data ends.

I believe the following does what you intended:


Dim c As Range, dataRng As Range
Set dataRng = ActiveCell.End(xlDown)
Set dataRng = Range(dataRng, dataRng.End(xlDown))
For Each c In dataRng


The first ``set dataRng`` finds the beginning of the data, assuming an empty
cell is selected and the data begins in the first non-empty cell below it.

The second ``set dataRng`` finds the end of the data, and it sets dataRng to
the entire data range.

In its entirety, the copyLeft macro becomes:


Sub CopyLeft()
'activecell must start row 1 to row 16 of column
Dim c As Range, dataRng As Range
Dim st As Double
st = Timer
Set dataRng = ActiveCell.End(xlDown)
Set dataRng = Range(dataRng, dataRng.End(xlDown))
For Each c In dataRng
If c.Offset(0, -1).Value = "X" Then
c.Resize(1, 2).Cut c.Offset(0, -2)
End If
Next
MsgBox Format(Timer - st, "0.000") & " sec"
End Sub

I installed a coded timer I got from one other contributor
into your code and it read out 29.9 seconds for the same
283 rows.

There seems to be defect in Excel 2010 or its VBA.

When I run the modified code in Excel 2007, it takes consistently less than
0.8 seconds to move 1500 rows to the left.

In Excel 2010, initially it takes about 3.4 seconds. And sometimes it is
consistent, at least for a while.

(Of course, times vary from computer to computer. The important things to
note is the __relative__ times.)

But eventually, I get into a state where the implementation takes
increasingly longer. I don't know why. And I don't know what clears that
state occassionally.

In any case, I wonder if that explains why your version and Garry's takes so
long.

Seems a bit slow but I will live with it.

You might not need to.

The use of range.Cut is the primary cause of the slow performance. Do you
really need to use range.Cut?

You might indeed need range.Cut if you want to move all of the cell's
formats as well as its value.

But in another posting, you indicated that the data are constants, not
formulas.

If you only need to move the values, not the formats, the following
implementation takes consistently about 0.031 seconds -- 100 times faster.


Sub CopyLeft()
Dim dataRng As Range
Dim v As Variant
Dim st As Double
Dim i As Long, n As Long
st = Timer
' copy 2 columns to the left as well as the 2 columns of data
Set dataRng = ActiveCell.End(xlDown)
Set dataRng = Range(dataRng, dataRng.End(xlDown)).Offset(0, -2).Resize(, 4)
v = dataRng
n = UBound(v, 1)
For i = 1 To n
If v(i, 2) = "X" Then
v(i, 1) = v(i, 3): v(i, 3) = ""
v(i, 2) = v(i, 4): v(i, 4) = ""
End If
Next
dataRng = v
MsgBox Format(Timer - st, "0.000") & " sec"
End Sub


Alternatively, if you need to also move the numeric format (but not all
formats like borders, alignment, condition format, etc), the following
implementation takes consistently about 0.5 seconds -- 6 times faster.


Sub CopyLeft()
Dim dataRng As Range
Dim v As Variant
Dim st As Double
Dim i As Long, n As Long
st = Timer
' copy 2 columns to the left as well as the 2 columns of data
Set dataRng = ActiveCell.End(xlDown)
Set dataRng = Range(dataRng, dataRng.End(xlDown)).Offset(0, -2).Resize(, 4)
v = dataRng
n = UBound(v, 1)
For i = 1 To n
If v(i, 2) = "X" Then
v(i, 1) = v(i, 3): v(i, 3) = ""
v(i, 2) = v(i, 4): v(i, 4) = ""
dataRng(i, 1).NumberFormat = dataRng(i, 3).NumberFormat
dataRng(i, 2).NumberFormat = dataRng(i, 4).NumberFormat
End If
Next
dataRng = v
MsgBox Format(Timer - st, "0.000") & " sec"
End Sub

 

[Howard]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

Hi Claus,

My Excel 2010 Conditional formatting for this sheet is: Home > Conditional formatting > High light CF Rules > Duplicate Values > Duplicate Box > Format cells that contain: "Duplicate" values with "Light Red Fill" > OK.

So there is no formula.

Howard

 

[Claus Busch]

Hi Howard,

Am Sun, 7 Oct 2012 01:53:15 -0700 (PDT) schrieb Howard:

My Excel 2010 Conditional formatting for this sheet is: Home > Conditional formatting > High light CF Rules > Duplicate Values > Duplicate Box > Format cells that contain: "Duplicate" values with "Light Red Fill" > OK.

try in A1:
=IF(COUNTIF($B$1:B1,B1)>1,"X","")
and copy down


Regards
Claus Busch

 

[Howard]

Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column,same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard

 

[Howard]

Garry,

I tried your code and it works fine.

I'm surprised to see you say that. It does not have the functionality that

your implementation does.



In particular, your original implementation seems to assume that an empty

cell above the data is selected. Your code was:





'activecell must start row 1 to row 16 of column

[....]

ActiveCell.End(xlDown).Select

j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select





But that implementation is flawed unless that data starts in row 17. If

not, Resize(j-16,1) specifies more than the number of rows in the table.

How much more depends on where the data ends.



I believe the following does what you intended:





Dim c As Range, dataRng As Range

Set dataRng = ActiveCell.End(xlDown)

Set dataRng = Range(dataRng, dataRng.End(xlDown))

For Each c In dataRng





The first ``set dataRng`` finds the beginning of the data, assuming an empty

cell is selected and the data begins in the first non-empty cell below it..



The second ``set dataRng`` finds the end of the data, and it sets dataRngto

the entire data range.



In its entirety, the copyLeft macro becomes:





Sub CopyLeft()

'activecell must start row 1 to row 16 of column

Dim c As Range, dataRng As Range

Dim st As Double

st = Timer

Set dataRng = ActiveCell.End(xlDown)

Set dataRng = Range(dataRng, dataRng.End(xlDown))

For Each c In dataRng

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

MsgBox Format(Timer - st, "0.000") & " sec"

End Sub

I installed a coded timer I got from one other contributor

into your code and it read out 29.9 seconds for the same

283 rows.

There seems to be defect in Excel 2010 or its VBA.



When I run the modified code in Excel 2007, it takes consistently less than

0.8 seconds to move 1500 rows to the left.



In Excel 2010, initially it takes about 3.4 seconds. And sometimes it is

consistent, at least for a while.



(Of course, times vary from computer to computer. The important things to

note is the __relative__ times.)



But eventually, I get into a state where the implementation takes

increasingly longer. I don't know why. And I don't know what clears that

state occassionally.



In any case, I wonder if that explains why your version and Garry's takesso

long.

Seems a bit slow but I will live with it.

You might not need to.



The use of range.Cut is the primary cause of the slow performance. Do you

really need to use range.Cut?



You might indeed need range.Cut if you want to move all of the cell's

formats as well as its value.



But in another posting, you indicated that the data are constants, not

formulas.



If you only need to move the values, not the formats, the following

implementation takes consistently about 0.031 seconds -- 100 times faster..





Sub CopyLeft()

Dim dataRng As Range

Dim v As Variant

Dim st As Double

Dim i As Long, n As Long

st = Timer

' copy 2 columns to the left as well as the 2 columns of data

Set dataRng = ActiveCell.End(xlDown)

Set dataRng = Range(dataRng, dataRng.End(xlDown)).Offset(0, -2).Resize(, 4)

v = dataRng

n = UBound(v, 1)

For i = 1 To n

If v(i, 2) = "X" Then

v(i, 1) = v(i, 3): v(i, 3) = ""

v(i, 2) = v(i, 4): v(i, 4) = ""

End If

Next

dataRng = v

MsgBox Format(Timer - st, "0.000") & " sec"

End Sub





Alternatively, if you need to also move the numeric format (but not all

formats like borders, alignment, condition format, etc), the following

implementation takes consistently about 0.5 seconds -- 6 times faster.





Sub CopyLeft()

Dim dataRng As Range

Dim v As Variant

Dim st As Double

Dim i As Long, n As Long

st = Timer

' copy 2 columns to the left as well as the 2 columns of data

Set dataRng = ActiveCell.End(xlDown)

Set dataRng = Range(dataRng, dataRng.End(xlDown)).Offset(0, -2).Resize(, 4)

v = dataRng

n = UBound(v, 1)

For i = 1 To n

If v(i, 2) = "X" Then

v(i, 1) = v(i, 3): v(i, 3) = ""

v(i, 2) = v(i, 4): v(i, 4) = ""

dataRng(i, 1).NumberFormat = dataRng(i, 3).NumberFormat

dataRng(i, 2).NumberFormat = dataRng(i, 4).NumberFormat

End If

Next

dataRng = v

MsgBox Format(Timer - st, "0.000") & " sec"

End Sub

Wow, you've given me plenty to chew on. I will tinker with all your suggestions. I'm getting the feeling I am in over my head...

My data does indeed start in row 17 and I just needed a down and dirty way to separate the dupes into a seperate column and then I can minupliate the two columns data as I want. If I use copy it would leave the data in the first column and put a copy of that data in the columns to the left. So I switched to Cut so it would vacate the first column.

If I can get a way to auto install the X's in the left most column where the dupes occur I will be more than happy. Claus has a suggestion and I am off to give it a try along with all the nuggets you have suggested.

I sure do appreciat all the suggestions and dialog from everyone. Sorta like taking an advanced Excel class.

Thanks again to everyone for a ton of help.

Regards,
Howard

 

[Claus Busch]

Hi Howard,

Am Sun, 7 Oct 2012 03:08:57 -0700 (PDT) schrieb Howard:

My data does indeed start in row 17 and I just needed a down and dirty way to separate the dupes into a seperate column and then I can minupliate the two columns data as I want. If I use copy it would leave the data in the first column and put a copy of that data in the columns to the left. So I switched to Cut so it would vacate the first column.

If I can get a way to auto install the X's in the left most column where the dupes occur I will be more than happy. Claus has a suggestion and I am off to give it a try along with all the nuggets you have suggested.

I sure do appreciat all the suggestions and dialog from everyone. Sorta like taking an advanced Excel class.

enter the "X" with the formual. That's the quickest way to do it.
You are looking for the "X" in column A and then cut B and C in the same
row and paste it to A? Then give following code a try:

Sub CopyLeft()
Dim myRng As Range
Dim FRow As Long
Dim LRow As Long
Dim rngC As Range
Dim st As Double

st = Timer

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

LRow = Cells(Rows.Count, 2).End(xlUp).Row
FRow = WorksheetFunction.Match("X", Range("A1:A" & LRow), 0)
Set myRng = Range(Cells(FRow, 2), Cells(LRow, 2))

For Each rngC In myRng
With rngC
If .Offset(0, -1) = "X" Then
.Resize(1, 2).Cut Destination:=.Offset(0, -1)
End If
End With
Next
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With
MsgBox Format(Timer - st, "0.000") & " sec"
End Sub

In 2500 rows with 300 duplicates it took 2,175 sec.


Regards
Claus Busch

 

[joeu2004]

My data does indeed start in row 17 and I just needed a
down and dirty way to separate the dupes into a seperate
column and then I can minupliate the two columns data as
I want.

How about a clean way? ;-)

First, if your are using Conditional Formatting only for this purpose, and
if the following suggestions work for you, it is important that you
eliminate the CFs.

In other forums, others have claimed that (some) CFs are "volatile"
formulas. So for each cut-and-paste that you might do, __all__ of the CFs
are re-evaluated. And that might sense given your application.

That could explain why your algorithm takes so much longer for you (18 to 30
sec, you said) than for me (3.4 sec, but increasing each time sometimes).

Second, the following macro might do what you require. It assumes that you
format the columns separately. It also assumes that you select at least the
upper-left cell of the 2-column data.

The following macro behaves similar to yours: it simply moves duplicates to
the left. That leaves gaps in the original data.

On my computer (YMMV), the run time is less than 0.08 seconds for 1500 data
with 1499 duplicates (worst case), compared to 3.4 seconds or more for your
cut-and-paste algorithm.

Caveat: I am guessing at the condition that identifies a duplicate, namely
that the values in __both__ columns are the same; that is:

If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then

Remove either ``And orig(j, 2) = orig(i, 2)`` or ``orig(j, 1) = orig(i, 1)
And`` if only one comparison is needed.


' assume upper-left cell of data is selected
' and data are 2 rows or more
Sub moveDupe()
Dim st As Double
Dim origRng As Range
Dim orig As Variant
Dim n As Long, i As Long, j As Long
st = Timer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set origRng = Range(ActiveCell, ActiveCell.End(xlDown)).Resize(, 2)
orig = origRng
n = UBound(orig, 1)
ReDim dupe(1 To n, 1 To 2) As Variant
For i = 1 To n - 1
If orig(i, 1) <> "" And orig(i, 2) <> "" Then
For j = i + 1 To n
If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then
dupe(j, 1) = orig(j, 1)
dupe(j, 2) = orig(j, 2)
orig(j, 1) = ""
orig(j, 2) = ""
End If
Next
End If
Next
origRng = orig
origRng.Offset(0, -2) = dupe
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
MsgBox Format(Timer - st, "0.000") & " sec"
End Sub


The following macro builds two lists so that are no gaps in either one. The
run time is about the same, under 0.08 seconds on my computer.


' assume upper-left cell of data is selected
' and data are 2 rows or more
Sub moveDupe()
Dim st As Double
Dim origRng As Range
Dim orig As Variant
Dim n As Long, i As Long, j As Long
Dim un As Long, dn As Long
st = Timer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set origRng = Range(ActiveCell, ActiveCell.End(xlDown)).Resize(, 2)
orig = origRng
n = UBound(orig, 1)
ReDim uniq(1 To n, 1 To 2) As Variant
ReDim dupe(1 To n, 1 To 2) As Variant
un = 0: dn = 0
For i = 1 To n - 1
If orig(i, 1) <> "" And orig(i, 2) <> "" Then
For j = i + 1 To n
If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then
dn = dn + 1
dupe(dn, 1) = orig(j, 1)
dupe(dn, 2) = orig(j, 2)
orig(j, 1) = ""
orig(j, 2) = ""
End If
Next
un = un + 1
uniq(un, 1) = orig(i, 1)
uniq(un, 2) = orig(i, 2)
End If
Next
origRng = uniq
origRng.Offset(0, -2) = dupe
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
MsgBox Format(Timer - st, "0.000") & " sec"
End Sub

 

[GS]

I only tested 16 rows of data because that't what I understood the row
count to be from your original post. In my test the result was
instantaneous.

As I originally suggested, dumping the data into an array and working
with it there before dumping the array back into the sheet is the
fastest (IMO) way to do this sort of thing. Joeu2004 invested an
impressive amount of time to demonstrate how to do this with a very
good example that also times the process. While his sample code may
seem rather complex to you initially, it's a good demo for this
approach and so I'd recommend you invest the time required to 'get it'
and put it under your belt for future use!

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Ben McClave]

Howard,

It seems to me like your original hunch might be right as far as the UsedRange being larger than expected. Excel will run very slowly if an entire column or row of data is being "used".

The quickest way to check this is to press CTRL+End to go to the last used cell on your sheet. If it is way outside of the data range you expect, then delete all unused columns and rows (select an entire column, then press CTRL+Shift+Right Arrow to select all columns, then delete; use a similar approach to delete rows).

After all unused rows and columns are gone, save and close the workbook andreopen it. Press CTRL+End again to see where the data range ends. Run your macros again and click CTRL+End a final time to see if your macros may be inadvertently increasing the size of your UsedRange (for example, by applying formatting to an entire row or column).

Hope this helps,

Ben