ve</p> <p>VBA çok yeni ... sadece yaklaşık bir hafta boyunca onunla oynamaya edilmiş, ve bir optimize etmek için yardımına ihtiyacım var ... VBA kodunu

Question

İyi akşamlar Optimize ihtiyaç makro.

Çalışması için yaklaşık 23 saniye gerekiyor ... ve biraz düşürmeyi umuyordu. "Gizli" den "UPS Tarifesi"

kopyalanmıştır L:

ilk adım sonra DB'den bir tablo "gizli" ve son olarak sütunlar B adı verilen bir çalışma içine indirilir "dosya konumu seçin" bir buton olup

Herhangi öneri büyük Sen tüm süreci yavaşlatıyor olabilir bir OLEDB Bağlantı yapıyoruz

Sub Selectfile() 

Dim filename As String 

filename = Application.GetOpenFilename(MultiSelect:=False) 

Range("c2") = filename 

Dim StartTime As Double 
Dim SecondsElapsed As Double 
StartTime = Timer 

Dim cnn As ADODB.Connection 
Dim rs As ADODB.Recordset 
Dim sQRY As String 
Dim rng As Range 
Dim cell As Range 
Dim sourcefile As String 


sourcefile = Sheet1.Range("C2") 
Sheets("Hidden").Visible = True 
Set cnn = New ADODB.Connection 
Set rs = New ADODB.Recordset 
Set rng = Sheet9.Range("B1:B762") 

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
"Data Source=" & sourcefile & ";" 
sQRY = "SELECT * FROM Tariff" 
rs.CursorLocation = adUseClient 
rs.Open sQRY, cnn, adOpenStatic, adLockReadOnly 
Application.ScreenUpdating = False 
Sheet9.Range("A1").CopyFromRecordset rs 
rs.Close 
Set rs = Nothing 
cnn.Close 
Set cnn = Nothing 

For Each cell In rng 
If cell <> "Letter" And cell <> "NDA" And cell <> "NDAS" And cell <> "2DA" And cell <> "3DS" And cell <> "GND" Then cell.Value = cell.Value * 1 
Next cell 

    Sheets("Hidden").Select 
    Range("B1").Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 
    Sheets("UPS Tariff").Select 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
     :=False, Transpose:=False 
    Range("A1").Select 
    Sheets("Hidden").Select 
    Range("A1").Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Application.CutCopyMode = False 
    Selection.Clear 
    Sheets("Info").Select 

Sheets("Hidden").Visible = xlVeryHidden 
SecondsElapsed = Round(Timer - StartTime, 2) 

'Notify user in seconds 
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation 

End Sub 

Answer 1

takdir edilmektedir. Bununla birlikte, kodunuzda geliştirebileceğiniz birkaç şey vardır:

• 1) Çok fazla range.selects yapmayın.

• 2) Kodunuzda bulunan with ifadesini kullanmayı deneyin. Bu işleminizi biraz hızlandırır. Örneğin

  Aşağıdaki kod:

  Sheets("Hidden").Select 
  Range("B1").Select 
  Range(Selection, Selection.End(xlToRight)).Select 
  Range(Selection, Selection.End(xlDown)).Select 
  Selection.Copy 
  Sheets("UPS Tariff").Select 
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 
  Range("A1").Select 
  Sheets("Hidden").Select 
  Range("A1").Select 
  Range(Selection, Selection.End(xlToRight)).Select 
  Range(Selection, Selection.End(xlDown)).Select 
  Application.CutCopyMode = False 
  Selection.Clear 
  Sheets("Info").Select 
  

böyle bir şeye dönüştürülebilir Could:

With Sheets("Hidden") 
     'copy your selection 
     .Range(.cells(1,2), .cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Copy' e.g. if you want to select the whole area in the worksheet 

     'paste selection to the destination cell 
     Sheets("UPS Tariff").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
      :=False, Transpose:=False 

     Application.CutCopyMode = False'gets rid of the highlighted copy area under your Sheets workbook 

     'clears the initial selection 
     .Range(.cells(1,2), .cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).Clear 
    End With 

    Sheets("Info").Select 

Sadece kod VBA işlemci için daha verimli hale gelmesi, ancak Ayrıca gözden geçirmeniz/değiştirmeniz gerektiğinde sizin için daha okunabilir.

gerçekten sürecini hızlandırır o başka şey şu satırlar vardır:

Application.ScreenUpdating = False 

yukarıdaki kodun her zaman yeni bir çizgi titreyen ekran durur yürütülür.

Application.Calculation = xlCalculationManual 

Yukarıdakiler, çalışma sayfasında her değişiklik yaptığınızda yeniden hesaplanacak tüm formülleri durdurur. emin olmak gerekir Ancak böyle worksheet_Activate, Worksheet_Change, ...

gibi tüm çalışma sayfası olayları devre dışı bırakır

Application.EnableEvents = false 

Bir tane, bir kez tüm kod çalışması bittikten göre, yeniden bu özellikleri açmak (aksi takdirde hücreler duracak yeniden hesaplanıyor ve ekran kendini yenilemekten vazgeçecek).

Normalde yaptığım şey, tüm desteğini kodunu koydum yeni bir modül oluşturduğumdur. Orada şu iki işlevi oluşturun:

Public Sub EnableExcel() 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 
    Application.EnableEvents = True 
End Sub 

Public Sub DisableExcel() 
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
    Application.EnableEvents = False 
End Sub 

Gördüğünüz gibi, bu işlevler public olarak işaretlenir ve bu nedenle vardır çalışma kitabınızda dahilinde her yerden erişilebilir.

Sonra prosedür şu şekilde görünecektir: Gördüğünüz Ne

Private Sub DoSomeStuff() 
    On Error GoTo EarlyExit 
    Call DisableExcel 

    'this will fail as it is division by zero 
    MsgBox 1/0 

EarlyExit: 
    Call EnableExcel 
    If Err.Description <> vbNullString Then MsgBox Err.Description 
End Sub 

, önemli hata alıcı olduğunu. Gerçekten bu çevrimiçi hakkında daha fazla okumaya alışkınım. Temel olarak kodun burada ne olduğu, eğer kod yürütme sırasında bir şey başarısız olursa (sıfıra bölmeye çalıştığınıza dair bir örnek yaptım), kod tamamen başarısız olmaz, ancak hata mesajını kullanıcıya gösterecektir. Hata tanımlaması. Ayrıca, kod başarısız olursa, EnableExcel makronuzun ne olursa olsun yürütülmesini sağlar.

Bunlar gerçekten verebileceğim birkaç ipucudur. VBA ile ne kadar çok çalışırsanız ve okuduğunuz (ör. StackOverflow'ta), ne kadar iyi olursanız o kadar iyi olur. İyi şanslar!