VBA复制粘贴代码不粘贴任何东西

Question

有人可以告诉我为什么我的代码没有将源数据中的任何内容粘贴到目标文件吗？ 此代码的目标是选择满足特定条件的行，将其复制粘贴到另一个工作簿中，代码如下所示：

 

Sub Copy_Source_LRE() 

Dim LastRow As Integer, i As Integer, erow As Integer

Workbooks.Open _

"C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv"

Worksheets("AAPAF_strategy_loadings_2019-04").Activate

Set sht = ActiveSheet

'Workbooks("AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv").Sheets("AAPAF_strategy_loadings_2019-04").Activate

LastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row

For i = 2 To LastRow

For Each d In Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _

"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020") 

    If Cells(i, 2) = d And Cells(i, 3) = "Real Estate" And Cells(i, 4) = "Listed Real Estate" And Cells(i, 5) = "AAPAF_SA" Then

    Range(Cells(i, 2), Cells(i, 12)).Select

    Selection.Copy
    Workbooks.Open _
    "C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\pull data.xlsm"
    Worksheets("Sheet1").Select

    erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    ActiveSheet.Cells(erow, 1).Select
    ActiveSheet.Paste
    ActiveWorkbook.Save
'ActiveWorkbook.Close
    End If
Next d

Next i

Application.CutCopyMode = False

End Sub

---

Answer 1

这是一种非常简单且基本的方法，我一直使用它来将数据复制到新工作簿中。在此示例中，我将一个名为“MasterData”的命名范围复制到一个新的空白工作簿中。然后我用密码保存那本新书并重新激活当前工作簿。

Dim newfilename As String
newfilename = "/Users/" & userName & "/Desktop/savedWorkbook.xlsx"
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
ThisWorkbook.Activate
Sheets("Datasheet").Select
Range("MasterData").Copy
NewBook.Activate
NewBook.Sheets(1).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NewBook.SaveAs Filename:=newfilename, Password:="examplepassword", AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
NewBook.Close (True)
ThisWorkbook.Activate

Answer 2

我已经为您重新编写了代码，因为主要问题与并非真正必要的循环有关。应用这些标准和提取数据的最佳/快速方法是使用过滤器来应用它们，因此复制没有隐藏（不匹配）行的可见单元格，然后打开需要过去信息的第二个文件，找到下一个空白行在选择下方并一次粘贴所有行。 我正在粘贴下面的代码（使用 cmets），还保存了一个包含 3 个文件（代码、信息、数据库）的 zip 文件，这些文件可能反映了您的工作文件，链接如下。

VBS 代码：

Sub Copy_Source_LRE()
Dim LastRow As Integer, i As Integer, erow As Integer

Workbooks.Open ThisWorkbook.Path & "\" & "Wks1.xlsx" 'change the path and name here

Worksheets(1).Activate
Set sht = ActiveSheet
LastRow = Range("a1").SpecialCells(xlCellTypeLastCell).Row

datar = Range(Cells(LastRow, 12), Cells(1, 1)).Address 'data range

Range(datar).Select
Selection.AutoFilter 'create a filter,then use the criteria you need

ActiveSheet.Range(datar).AutoFilter Field:=2, Criteria1:= _
Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _
"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020"), Operator:=xlFilterValues 'your dates array can be update here

ActiveSheet.Range(datar).AutoFilter Field:=3, Criteria1:="Real Estate", Operator:=xlAnd

ActiveSheet.Range(datar).AutoFilter Field:=4, Criteria1:="Listed Real Estate", Operator:=xlAnd

ActiveSheet.Range(datar).AutoFilter Field:=5, Criteria1:="AAPAF_SA", Operator:=xlAnd

Range(datar).Offset(1, 0).Resize(Range(datar).Rows.Count - 1, Range(datar).Columns.Count).Select 'resize selection to remove the header
Selection.SpecialCells(xlCellTypeVisible).Select 'select visible cells only


Selection.Copy

Workbooks.Open ThisWorkbook.Path & "\" & "Wks2.xlsx" 'change the path and name here

Worksheets("Sheet1").Select
Range("A1").End(xlDown).Offset(1, 0).Select 'goes to the last row on column A the goes another one - 1st empty
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=True 'close and save your  database
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False 'close without saving your csv file

End Sub

文件/代码链接：https://drive.google.com/file/d/1zL_TwclHR4lrNhKB1xODGAmliPHM1r3K/view?usp=sharing

如果解决方案符合您的需要，请考虑作为解决方案。问候！