Excel VBA复制粘贴数据太慢

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

我有以下代码，这些代码从我的工作簿中的许多工作表中获取数据，并将其转储到名为“ Export_Sheet”的新工作表中。

由于代码依赖于Copy \ Paste方法，所以它要花很长的时间，而我希望用更快的方法替换它。

任何线索？我并不是在寻求解决方案，而只是在朝着正确的方向发展，因为我自己并不知道有任何更快的过程，但是我确信它们存在。

Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Worksheets.Add(After:=Worksheets(1)).Name = "Export_Sheet"

Dim Ws As Worksheet

For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And Ws.Name <> "Mid Team Project List" And Ws.Name <> "Rear Team Project List" And Ws.Name <> "Acronyms" Then

LastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row

For i = 6 To LastRow

Ws.Cells(i, 9).EntireRow.Copy
Sheets("Export_Sheet").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial xlPasteValues
Sheets("Export_Sheet").Range("j" & Rows.Count).End(xlUp).Value = Ws.Name

If Ws.Range("J1").Value = "Front Team" Then
Sheets("Export_Sheet").Range("k" & Rows.Count).End(xlUp).Offset(1).Value = "Front Team"
End If

If Ws.Range("J1").Value = "Mid Team" Then
Sheets("Export_Sheet").Range("k" & Rows.Count).End(xlUp).Offset(1).Value = "Mid Team"
End If

If Ws.Range("J1").Value = "Rear Team" Then
Sheets("Export_Sheet").Range("k" & Rows.Count).End(xlUp).Offset(1).Value = "Rear Team"
End If

Next i

End If
Next
End Sub
excel vba copy paste
3个回答
0
投票

请尝试使用此代码：

Private Sub CommandButton3_Click()
 Dim Ws As Worksheet, lastRow As Long, lastCol As Long
 Dim shExp As Worksheet, arrTransf As Variant

  Set shExp = Worksheets.Add(After:=Worksheets(1))
  shExp.Name = "Export_Sheet"

 For Each Ws In ThisWorkbook.Worksheets
  If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And _
            Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And _
            Ws.Name <> "Mid Team Project List" And Ws.Name <> _
                      "Rear Team Project List" And Ws.Name <> "Acronyms" Then
    lastRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row

        lastCol = Ws.UsedRange.Columns.Count
        arrTransf = Ws.Range(Ws.Cells(6, 1), Ws.Cells(lastRow, lastCol)).value
        shExp.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arrTransf, 1), _
                                            UBound(arrTransf, 2)).value = arrTransf

        shExp.Range("j" & Rows.Count).End(xlUp).value = Ws.Name

        If Ws.Range("J1").value = "Front Team" Then _
            shExp.Range("k" & Rows.Count).End(xlUp).Offset(1).value = "Front Team"

        If Ws.Range("J1").value = "Mid Team" Then _
            shExp.Range("k" & Rows.Count).End(xlUp).Offset(1).value = "Mid Team"

        If Ws.Range("J1").value = "Rear Team" Then _
            shExp.Range("k" & Rows.Count).End(xlUp).Offset(1).value = "Rear Team"
  End If
 Next
End Sub
0
投票

确定，这是我直接传输而不是使用剪贴板的方式。可能会有更好的方法。

工作表的UsedRange属性是从Range（“ A1”）到Ctrl + End所处位置的所有内容。它的下方可能是空白单元格，但是Excel认为“已用范围”的结尾在此处。这需要限制.EntireRow的范围，否则它可能会延伸到整个工作表到＃16,384列，即列数的最大值。

我对您要复制的内容的理解有些不稳定，但是中间的那个循环是它的作用。首先，它使用Intersect（）将.UsedRange与要处理的行交叉。然后，它一次遍历源和目标范围，将一个单元格计数一次，然后将值从一个单元格复制到另一个单元格。

Private Sub CommandButton3_Click()
    Application.ScreenUpdating = False
    Worksheets.Add(After:=Worksheets(1)).Name = "Export_Sheet"

    Dim Ws      As Worksheet
    Dim ur      As Excel.range
    Dim srcCell As Excel.range
    Dim srcRng  As Excel.range
    Dim srcCnt  As Long
    Dim xferCnt As Long
    Dim topCell As Excel.range

    For Each Ws In ThisWorkbook.Worksheets
        Set ur = Ws.UsedRange 'This is usually A1 to where Ctrl+End sends you.
        If Ws.Name <> "Contents Page" And Ws.Name <> "Completed" And Ws.Name <> "VBA_Data" And Ws.Name <> "Front Team Project List" And Ws.Name <> "Mid Team Project List" And Ws.Name <> "Rear Team Project List" And Ws.Name <> "Acronyms" Then
            LastRow = Ws.Cells(rows.Count, 1).End(xlUp).row
            For i = 6 To LastRow
                Set srcRng = Intersect(ur, Ws.Cells(i, 9).EntireRow)    'Only get the used part of the row.
                srcCnt = dataRng.Cells.Count                            'Count of cells in source.
                For xferCnt = 0 To srcCnt - 1
                    'Now you basically need something like this,
                    'Get the top cell as a reference point.
                    Set topCell = Sheets("Export_Sheet").range("A" & rows.Count).End(xlUp).Offset(1)
                    'Then transfer each cell one at a time.
                    topCell.Offset(0, xferCnt).Value = srcRng.Cells(xferCnt).Value
                    Sheets("Export_Sheet").range("j" & rows.Count).End(xlUp).Value = Ws.Name
                Next
                If Ws.range("J1").Value = "Front Team" Then
                    Sheets("Export_Sheet").range("k" & rows.Count).End(xlUp).Offset(1).Value = "Front Team"
                End If
                If Ws.range("J1").Value = "Mid Team" Then
                    Sheets("Export_Sheet").range("k" & rows.Count).End(xlUp).Offset(1).Value = "Mid Team"
                End If
                If Ws.range("J1").Value = "Rear Team" Then
                    Sheets("Export_Sheet").range("k" & rows.Count).End(xlUp).Offset(1).Value = "Rear Team"
                End If
            Next i
        End If
    Next
End Sub
0
投票

这不解决您的特定代码；它只是演示了一种替代方法。这种代码：

Sub CopyPaste()
    Sheets("Sheet1").Range("A1:Z100").Copy
    Sheets("Sheet2").Range("A1").PasteSpecial (xlPasteValues)
End Sub

除非它在大循环中执行，否则看起来可能非常快。如果您只有数据（（无公式）] >>，则：

Sub Value2Value()
    Sheets("Sheet2").Range("A1:Z100").Value = Sheets("Sheet1").Range("A1:Z100").Value
End Sub

更快。如果块中有公式，则：
Sub Form2Form()
    Sheets("Sheet2").Range("A1:Z100").Formula = Sheets("Sheet1").Range("A1:Z100").Formula
End Sub

将复制公式和数据。

快速复制的缺点是格式可能无法与值一起复制。

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