Paste code running extremely slowly...

[KR]

I had what I thought was a small and simple code snippet, but it was running
very slowly. So, I broke it out into component actions to see what was
taking so long. The code is pasted below; the first part of the code runs as
quickly as expected (considering the number of rows) but when I get to the
code to paste the data back into my worksheet, it seems to be taking about 1
second /per row/. Since I'm only pasting one value per row, and it is
already calculated, this seems very weird to me.

The sheet is not protected, and what is being pasted is never more than an 8
character string. Any ideas what might make this part of the code run so
painfully slowly?

Thanks,
Keith

-------------------------------------------------------
Sub OneTimeOnlyAdd()
Dim TempID As String
Dim NameArr(1 To 2, 1 To 10000)

'pull in the long name for editing
For PullVals = 1 To 10000
NameArr(1, PullVals) = Sheet43.Range("O" & Trim(Str(PullVals))).Value
Next

'edit the name
FoundBlank = 0
For AddID = 1 To 10000
If FoundBlank > 20 Then Exit For
TempID = NameArr(1, AddID)
If Len(TempID) > 0 Then
NameArr(2, AddID) = Right(TempID, Len(TempID) - InStr(TempID, "\"))
Else
FoundBlank = FoundBlank + 1
End If
Next

'paste the name <----this is the part that slows to a crawl!! one second per
loop! no sheet protection or anything, it just overwrites the current cell
value...
For PasteVals = 1 To 10000
Sheet43.Range("W" & Trim(Str(PasteVals))).Value = NameArr(2, PasteVals)
Next

End Sub

 

[Tom Ogilvy]

If that is all your doing, there is no reason to save the old value and use
the array the way you are doing it.

Sub OneTimeOnlyAdd()
Dim TempID As String
Dim NameArr As Variant

'pull in the long name for editing
For PullVals = 1 To 10000
NameArr= Sheet43.Range("O1:O10000").value
Next

'edit the name
FoundBlank = 0
For AddID = 1 To 10000
TempID = NameArr( AddID,1)
If Len(TempID) > 0 Then
NameArr(AddID,1) = Right(TempID, Len(TempID) - InStr(TempID, "\"))
Else
FoundBlank = FoundBlank + 1
NameArr(AddID,1) = empty
End If
Next

Application.ScreenUpdating = False
v = Application.Calculation
Application.Calculation = xlManual
Sheet43.Range("W1:W10000")Value = NameArr
Application.Calculation = v
Application.ScreenUpdating = True
End Sub