0

我有下面看到的代码来复制未知数量的行（行有时最多 20k，仅列 (6)）并将其粘贴到不同的工作簿中。但它的屏幕更新、计算模式、启用事件运行速度极慢。没变。请帮忙

Sub CopyData()
Dim sh1 As Worksheet
Dim ShData As Worksheet
Dim sh5 As Worksheet
Dim LR As Long
Dim rng As Range
ThisWorkbook.Worksheets("Destnation").Activate
Set ShData = Workbooks("Data.xlsx").Worksheets(2)
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Set sh5 = ThisWorkbook.Worksheets("Destnation")

LR = ShData.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ShData.Range("A2:A" & LR)
rng.EntireRow.Copy sh5.Range("A2")
sh1.Range("H1").Value = Workbooks("Data.xlsx").Worksheets(2).Name
End Sub

谢谢

4

4 回答 4

2

如果您只对值感兴趣，则可以使用对象的.Value属性Range，适当调整粘贴范围

Sub CopyData()

    Dim sourceRng  As Range
    Dim sourceSheetName As String
    
    With Workbooks("Data.xlsx").Worksheets(2)
        Set sourceRng = .Range("A2", .Cells(Rows.Count, 1).End(xlUp)) ' set the source range
        sourceSheetName = .Name
    End With
    
    With ThisWorkbook
        .Worksheets("Destnation").Range("A2").Resize(sourceRng.Rows.Count).Value = sourceRng.Value
        .Worksheets("Sheet1").Range("H1").Value = sourceSheetName
    End With
    
End Sub
于 2020-11-15T17:47:59.950 回答
1

请尝试下一个代码。无需激活、选择和剪贴板使用。也不需要复制整行。但它不会复制格式：

Sub CopyDataCC()
 Dim sh1 As Worksheet, ShData As Worksheet, sh5 As Worksheet
 Dim LR As Long, LCol As Long, arrCopy

 Set ShData = Workbooks("Data.xlsx").Worksheets(2)
 Set sh1 = ThisWorkbook.Worksheets("Sheet1")
 Set sh5 = ThisWorkbook.Worksheets("Destnation")

 LR = ShData.cells(rows.count, 1).End(xlUp).row
 LCol = ShData.cells(2, Columns.count).End(xlToLeft).Column

 arrCopy = ShData.Range("A2", ShData.cells(LR, LCol))
 sh5.Range("A2").Resize(UBound(arrCopy), UBound(arrCopy, 2)).Value = arrCopy
 sh1.Range("H1").Value = Workbooks("Data.xlsx").Worksheets(2).Name
End Sub
于 2020-11-15T14:49:49.573 回答
0

如果您只关心值，Fandune 和 user3598756 都是最佳选择，可能就是这种情况。但是你没有在你的帖子中指定，所以我会为真正需要捕获格式的任何人添加我的答案（也许有日期？）

请在下面尝试此操作，并注意对您的某些代码的评论。

Sub CopyData()
'This macro is running from the file where the data is being pasted.


Dim ShData As Worksheet 'this file is presumed to be open
    Set ShData = Workbooks("Data.xlsx").Worksheets(2)
    
Dim sh5 As Worksheet
    Set sh5 = ThisWorkbook.Worksheets("Destnation")

Dim LR As Long 'this will work so long as no rows are hidden
    LR = ShData.Cells(Rows.Count, 1).End(xlUp).Row

Dim rng As Range 'no need to do entire rows. Probably your biggest issue.
    Set rng = ShData.Range("A2:G" & LR)

'copies Data.XLSX sheet 2 to Destination in the file WHERE this macro is being called
rng.Copy sh5.Range("A2")

'Not sure what this is doing other than trying to put a sheet name somewhere where macro is called.
Dim sh1 As Worksheet
    Set sh1 = ThisWorkbook.Worksheets("Sheet1")
    sh1.Range("H1").Value = ShData.Name
End Sub
于 2020-11-15T18:07:40.443 回答
0

从复制替换中删除整个行属性

Set rng =shData.Range(ShData.cells(2,1),ShData.cells(LR,ShData.cells(1,columns.count).xl(toleft).column))

于 2020-11-15T14:39:42.407 回答