Question

我已经在VBA编辑器（Excel）中编写了代码。基本上，代码定义了这是哪个项目（因为使用此代码有多个工作表）。然后，它将数据复制并粘贴到概述工作簿的右列和右行中（所有文件都在其中发送数据）。这样我就可以很好地了解我的项目。

但是现在我想优化代码，以便更快。我有两个不同的代码，其中一个代码如下所示。

我知道通过禁用屏幕更新和计算等功能可以使代码更快。

我的问题是：如何改善代码本身？

Option Explicit
Private Sub SyncToBureauplanner()

On Error GoTo Errormessage

'|  Define current projectplanner
    Dim Projectnumber As String
        Projectnumber = ActiveWorkbook.Sheets("Planning").Range("A6").Value2

    Dim Projectplanner As String
        Projectplanner = Projectnumber & ".xlsm"

'|  Define this week then find the column of this week
    Dim Currentweek As String
        Currentweek = Workbooks(Projectplanner).Sheets("Planning").Range("B5").Value2

    Dim CurrentweekColumn As Range
        With Workbooks(Projectplanner).Sheets("Planning").Range("2:2")
            Set CurrentweekColumn = .Find(What:=Currentweek, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False, Searchformat:=False)
        End With

'|  Define phasedata range
    Dim PhaseStart As Range
    Dim PhaseEnd As Range
    Dim Phasedata As Range

         With Workbooks(Projectplanner).Sheets("Planning")
            Set PhaseStart = .Range(Cells(9, CurrentweekColumn.Column).Address)
            Set PhaseEnd = .Range(Cells(10, CurrentweekColumn.Offset(0, 106).Column).Address)
            Set Phasedata = .Range(PhaseStart, PhaseEnd)
        End With

'|  Locate the Bureauplanning and open it | Disable filters
    Dim BureauplannersPath As String
        BureauplannersPath = "J:\Planning\Bureauplanning\"

    Dim Bureauplanner As String
        Bureauplanner = "Bureauplanning.xlsm"

    Dim BureauplannersFile As String
        BureauplannersFile = BureauplannersPath & Bureauplanner

        Workbooks.Open (BureauplannersFile)
            Workbooks(Bureauplanner).Sheets("planning").Activate
                If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData


'|  Define column where Phasedata is going to be pasted
    Dim CurrentWeekBureauplanner As Range
        With Workbooks(Bureauplanner).Sheets("planning").Range("L2:DO2")
            Set CurrentWeekBureauplanner = .Find(What:=Currentweek, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False, Searchformat:=False)
                If Not CurrentWeekBureauplanner Is Nothing Then
                End If
    End With

'|  Define row where Phasedata is going to be pasted
    Dim ThisProjectRow As Range
        With Workbooks(Bureauplanner).Sheets("planning").Range("A:A")
            Set ThisProjectRow = .Find(What:=Projectnumber, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False, Searchformat:=False)
                If Not ThisProjectRow Is Nothing Then
                End If
        End With

'|  Define range where Phasedata is going to be pasted
    Dim PasteStartCell As Range
    Dim PasteEndCell As Range
        With Workbooks(Bureauplanner).Sheets("planning")
            Set PasteStartCell = .Cells(ThisProjectRow.Offset(-1, 0).Row, CurrentWeekBureauplanner.Column)
            Set PasteEndCell = .Cells(ThisProjectRow.Row, CurrentWeekBureauplanner.Offset(0, 106).Column)
        End With

    Dim PasteRange As Range
        Set PasteRange = Range(PasteStartCell, PasteEndCell)

'|  Execute copy and paste
    PasteRange = Phasedata.Value

'|  Save and close the Bureauplanner
    With Workbooks(Bureauplanner)
        .Save
        .Close
    End With

'|  End of the Code
Exit Sub

'|  Error messages
Errormessage:
MsgBox ("Er is iets mis gegaan, controleer de code")

End Sub

优化代码的方法

0 个答案: