优化VBA范围复制/粘贴

问题描述 投票：0回答：1

我有这个当前代码，可以在循环中复制和粘贴值。它工作正常，但是当数据很多时需要很长时间才能完成。我认为有一种更有效的方法可以使用 .value 来做到这一点，但我需要一些关于如何实施的建议。

Sub Looping()
Dim OFFSETDOWN As String
Dim OFFSETLEFT As String
Dim OFFSETRITE As String
Dim FILEDONE As String
OFFSETDOWN = 1
OFFSETLEFT = 0
FILEDONE = "Calculate"

Sheets("Emp Data").Select
Range("E5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
Range("A10").Select
ActiveCell.Offset(2, 0).Select

Do Until FILEDONE = ""
'OFFSETDOWN = 0
'OFFSETLEFT = 0
'OFFSETRITE = 1

Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D14").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 4).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 2).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D13").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Results").Select

Range("D11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("J10").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Emp Data").Select
ActiveCell.Offset(0, 9).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Results").Select
Range("J12").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Results").Select
Range("J11").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Results").Select
Range("d8").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Results").Select
Range("d3").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Results").Select
Range("j26").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Results").Select
Range("j27").Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Emp Data").Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Sheets("Emp Data").Select
ActiveCell.Offset(1, -29).Select

FILEDONE = ActiveCell.Value
Loop


End Sub

我尝试实现其他教程中的 .value 方法，但我无法弄清楚如何正确实现它。任何有关改进此代码和更多地理解此主题的帮助将不胜感激。

excel vba loops copy-paste
1个回答
0
投票

改进宏记录器代码

  • 未测试！
Sub UpdateEmpData()
    
    ' Define constants.
    
    Const EMP_FIRST_ROW As Long = 12
    Const EMP_BLANK_INDEX As Long = 0
    
    Dim eColsRead() As Variant: eColsRead = VBA.Array( _
        "A", "B", "F", "G", "I", _
        "J", "K", "L", "M", "N", _
        "O")
    Dim rCellsWrite() As Variant: rCellsWrite = VBA.Array( _
        "D2", "D14", "D3", "D4", "D5", _
        "D6", "D13", "D15", "D8", "D10", _
        "D11")
    
    Dim rCellsRead() As Variant: rCellsRead = VBA.Array( _
        "J10", "J12", "J11", "D8", "D3", _
        "J26", "J27")
    Dim eColsWrite() As Variant: eColsWrite = VBA.Array( _
        "X", "Y", "Z", "AA", "AB", _
        "AC", "AD")
    
    ' Reference the objects (workbook and worksheets).

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ews As Worksheet: Set ews = wb.Sheets("Emp Data")
    Dim rws As Worksheet: Set rws = wb.Sheets("Results")
    
    ' Write...
    rws.Range("D1").Value = ews.Range("E5").Value
    
    ' Set the first row in Emp.
    Dim er As Long: er = EMP_FIRST_ROW
    
    ' Loop...
    
    Dim c As Long
    
    Do
        If Len(CStr(ews.Cells(er, eColsRead(EMP_BLANK_INDEX)).Value)) = 0 Then
            Exit Do ' when cell in column 'A' is blank
        End If
        ' Read from Emp, write to Results.
        For c = 0 To UBound(eColsRead)
            rws.Range(rCellsWrite(c)).Value = ews.Cells(er, eColsRead(c)).Value
        Next c
        ' Read from Results, write to Emp.
        For c = 0 To UBound(eColsWrite)
            ews.Cells(er, eColsWrite(c)).Value = rws.Range(rCellsRead(c)).Value
        Next c
        er = er + 1
    Loop

    ' Inform.
    MsgBox "Emp data updated.", vbInformation

End Sub
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.