excel - 如何在转置时绕过剪贴板

Question

我正在尝试加快复制大量数据的代码的速度。问题是我需要将沿行向下的范围复制到沿列向下的范围。

我尝试将范围设置为彼此相等，但这是行不通的。我还将计算设置设置为手动。这加快了一些速度，但没有我想要的那么多。

这是我在宏中的当前代码

CFFile.Sheets(CFTabName).Range("B" & RowIndex & ":CW" & RowIndex).Copy

SubmissionFile.Sheets(TargScenTabName).Range(ColumnIndex & "4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

我试过这段代码

SubmissionFile.Sheets(TargScenTabName).Range(ColumnIndex & "4").Value = CFFile.Sheets(CFTabName).Range("B" & RowIndex & ":CW" & RowIndex).Value

没有错误，但每个文件大约需要 2.5 分钟才能完成。

这是它所在的巨大丑陋代码

`Sub TranInsRiskCF()

Dim StartTime, EndTime As Double
StartTime = Now()
Application.ScreenUpdating = False

Const BOB_INDICATOR = ".xlsx"
Const DOLE_INDICATOR = ".xlsm"

Dim FileName As String
Dim TargTemplatePath As String
Dim CFFolderPath As String
Dim SubmissionFolderPath As String
Dim CFFilePath As String
Dim CFUnit As String
Dim CFDate As String
Dim CFIdentifier As String
Dim CFBOBOrDogTag As String
Dim TargScenTabName As String
Dim CFTabName As String
Dim ColumnIndex As String

Dim UnitRow As Integer
Dim ScenRow As Integer
Dim TabNameRow As Integer
Dim RowIndex As Integer
Dim CFScenNum As Integer

Dim SubmissionFile As Workbook
Dim CFFile As Workbook
Dim ThisBook As Workbook
Dim SubmissionName As String

Set ThisBook = ActiveWorkbook
ThisBook.Sheets("Control").Activate

'Store Path Information

FileName = Range("B5").Value
TargTemplatePath = Range("B6").Value
CFFolderPath = Range("B7").Value
SubmissionFolderPath = Range("B8").Value

'Start Unit Processing

UnitRow = 12

Do While Range("A" & UnitRow).Value <> ""

    CFUnit = Right(Range("A" & UnitRow).Value, 3)
    CFDate = Range("B" & UnitRow).Value
    Sheets("Tables").Activate


    RowIndex = 2
    Do While (Range("A" & RowIndex).Value <> CFUnit)
        RowIndex = RowIndex + 1
    Loop

    CFIdentifier = Range("B" & RowIndex).Value
    CFBOBorDOGTag  = Range("E" & RowIndex).Value

    If CFBOBorDOGTag  = BOB_INDICATOR Then
        If Left(CFUnit, 2) = "00" Then
            CFFilePath = CFFolderPath & "\" & "CF_ILB_0" & Right(CFUnit, 1) & "T_" & CFIdentifier & "_" & CFDate & CFBOBorDOGTag 
        ElseIf Left(CFUnit, 1) = "0" Then
            CFFilePath = CFFolderPath & "\" & "CF_ILB_" & Right(CFUnit, 2) & "T_" & CFIdentifier & "_" & CFDate & CFBOBorDOGTag 
        Else
            CFFilePath = CFFolderPath & "\" & "CF_ILB_" & CFUnit & "T_" & CFIdentifier & "_" & CFDate & CFBOBorDOGTag 
        End If

    ElseIf CFBOBorDOGTag  = DOLE_INDICATOR Then
        If Left(CFUnit, 2) = "00" Then
            CFFilePath = CFFolderPath & "\" & "CF_ILB_0" & Right(CFUnit, 1) & "T_" & CFIdentifier & "_" & CFDate & CFBOBorDOGTag 
        ElseIf Left(CFUnit, 1) = "0" Then
            CFFilePath = CFFolderPath & "\" & "CF_ILB_" & Right(CFUnit, 2) & "T_" & CFIdentifier & "_" & CFDate & CFBOBorDOGTag 
        Else
            CFFilePath = CFFolderPath & "\" & "CF_ILB_" & CFUnit & "T_" & CFIdentifier & "_" & CFDate & CFBOBorDOGTag 
        End If
    End If

   If Len(Dir(SubmissionFolderPath & "\" & FileName & "ILB " & CFUnit & ".xlsm")) = 0 Then
        Set SubmissionFile = Workbooks.Open(TargTemplatePath, , ReadOnly:=False)
        SubmissionName = "IRM_CF_201906_Template.xlsm"
    Else
        Set SubmissionFile = Workbooks.Open(SubmissionFolderPath & "\" & FileName & "ILB " & CFUnit & ".xlsm", ReadOnly:=False)
        SubmissionName = FileName & "ILB " & CFUnit & ".xlsm"

    End If

    Set CFFile = Workbooks.Open(CFFilePath, , ReadOnly:=True)

    Application.Calculation = xlCalculationManual

    'Start Scenario Processing

    ThisBook.Sheets("Control").Activate

    ScenRow = 12


    Do While Range("D" & ScenRow).Value <> ""
        TargScenTabName = Range("E" & ScenRow).Value
        CFScenNum = Range("D" & ScenRow).Value
        CFFile.Sheets("Market Risk CFs Output").Activate

        RowIndex = 3
        Do While (Range("A" & RowIndex).Value <> CFScenNum)
            RowIndex = RowIndex + 1
        Loop

        ThisBook.Sheets("Control").Activate

        TabNameRow = 12


            SubmissionFile.Unprotect Password:="cashflow1"
            SubmissionFile.Sheets(TargScenTabName).Visible = True
            SubmissionFile.Sheets(TargScenTabName).Unprotect Password:="cashflow1"


        Do While Range("G" & TabNameRow).Value <> ""
            CFTabName = Range("G" & TabNameRow).Value
            ColumnIndex = Range("H" & TabNameRow).Value
            CFFile.Sheets(CFTabName).Range("B" & RowIndex & ":CW" & RowIndex).Copy

            'SubmissionFile.Sheets(TargScenTabName).Range(ColumnIndex & "4").Value = CFFile.Sheets(CFTabName).Range("B" & RowIndex & ":CW" & RowIndex).Value

            SubmissionFile.Sheets(TargScenTabName).Range(ColumnIndex & "4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

            TabNameRow = TabNameRow + 1
        Loop

        ScenRow = ScenRow + 1


    Loop

    With SubmissionFile
        .Sheets(TargScenTabName).Protect Password:="cashflow1"
        .Sheets(TargScenTabName).Visible = False
    End With

    SubmissionFile.Sheets("Inputs").Activate
    Range("C5").Value = "Individual Life - Actuary"
    Range("C6").Value = "ILB " & CFUnit

    ActiveWorkbook.RefreshAll

    'Application.Run "'" & SubmissionName & "'" & "!ThisWorkbook.unhidethesheet"
    SubmissionFile.Protect Password:="cashflow1"

    Application.DisplayAlerts = False
    SubmissionFile.SaveAs (SubmissionFolderPath & "\" & FileName & "ILB " & CFUnit)
    SubmissionFile.Close
    Application.DisplayAlerts = True

    CFFile.Close False

'    SubmissionFile.Close

    UnitRow = UnitRow + 1

Application.ScreenUpdating = False


Loop

EndTime = Now()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic

MsgBox "Cash Flows Transferred." & vbCrLf & vbCrLf & _
       "Run Time: " & Format(StartTime - EndTime, "hh:mm:ss")

End Sub`

标签： excelvbacopy-pastetranspose