Tighten up the code

[newuser08]

Hi guys,

I've Tightened up the code to the best of my ability, any more suggestions speed things up?

Private Sub btnNewData_Click()
Dim xldcdata As Object
Application.Calculation = xlCalculationManual
frmworking.Show (0)
DoEvents
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False

Set xlBook = xlApp.Workbooks.Open("\\path\excelbook.xls")
Set xldcdata = xlBook.Worksheets("Data")
scandown = 6
HoldSelectedTime = Sheet2.Cells(8, 5) - 1
firstcheck = 0
Do
scandown = scandown + 1
holdlisttime = Left(xldcdata.Cells(scandown, 1), 10)
If holdlisttime = HoldSelectedTime Then
If firstcheck = 0 Then
checkblank = 1
Do
checkblank = checkblank + 1
Loop Until Sheet4.Cells(checkblank, 1) = ""
firstcheck = 1
Else
checkblank = checkblank + 1
End If
leftcell = "A" & scandown
rightcell = "E" & scandown
pastetocells = "A" & checkblank
Sheet4.Range(pastetocells & ":E" & checkblank - 1).Value = xldcdata.Range(leftcell, rightcell).Value
End If
Loop Until firstcheck = 1 And holdlisttime <> HoldSelectedTime

xlApp.DisplayAlerts = False
xlApp.Quit

Sheet4.Activate
'Remove Time
Sheet4.Range("A:A").Replace What:=" *", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

'Remove dups
Sheet4.Range("C:C").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Sheet4.Range("A1:E1").Select
Sheet4.Range(Selection, Selection.End(xlDown)).Select
Selection.copy

'Paste Data
Sheet1.Activate
Dim lRow As Long
lRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheet1.Paste Destination:=Sheet1.Cells(lRow, 1)

'clear imported work from temp sheet4
Sheet4.ShowAllData
Sheet4.Cells.ClearContents

Sheet2.Activate

xlApp.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
frmworking.Hide

End Sub


Thanks

 

[AnotherHiggins]

FYI: You can post in code blocks by surrounding your code with [ignore]

[/ignore] tags.

Just glancing over your code,

1)

        Sheet4.Range("A1:E1").Select
        Sheet4.Range(Selection, Selection.End(xlDown)).Select
        Selection.copy

can become

        Sheet4.Range([A1:E1], [A1:E1].End(xlDown)).copy

Or if you are copying all populated rows, calculate the last row beforehand and use is like range("A1:E" & intLstRow).copy

See
[tab]faq707-2112
or
[tab]faq707-2115
for info on finding last row.

2)
I'd suggest avoiding loops whenever possible.

3)

...
[b]firstcheck = 0[/b]
Do
    scandown = scandown + 1
    holdlisttime = Left(xldcdata.Cells(scandown, 1), 10)
    If holdlisttime = HoldSelectedTime Then
        [b]If firstcheck = 0 Then[/b]
...

How is it ever NOT going to be 0?

[tt]_____
[blue]-John[/blue][/tt]
[tab][red]The plural of anecdote is not data[/red]

Help us help you. Please read FAQ 181-2886 before posting.

 

[Gavona]

Application.ScreenUpdating = False
[your code]
Application.ScreenUpdating = True

Gavin

 

[newuser08]

Thanks for your advise Guys,

However when I made the below changes as adivesd by Gavona (in Red)

'Remove dups
    Sheet4.Range("C:C").AdvancedFilter Action:=xlFilterInPlace, Unique:=True

        [COLOR=green]'Sheet4.Range("A1:E1").Select
        'Sheet4.Range(Selection, Selection.End(xlDown)).Select
        'Selection.copy[/color]

    [COLOR=red]Sheet4.Range([A1:E1], [A1:E1].End(xlDown)).copy[/color]

It produces a 'Method 'Range' of object'_Worksheet' failed'

Have I missed something simple?

 

[SkipVought]

Hi,

Sheet4 must be there parent object for ALL the objects in your statement...

    Sheet4.Range(Sheet4.[A1:E1], Sheet4.[A1:E1].End(xlDown)).copy

Is this the...

Clash of the Tightens?


Skip,
[sub]
Just traded in my old subtlety...
for a brand NUANCE![/sub]