Коды копирования VBA ничего не вставляют - PullRequest
Новая
       8

Коды копирования VBA ничего не вставляют

0 голосов
/ 09 июля 2020

Может ли кто-нибудь сообщить мне, почему мой код ничего не вставляет из исходных данных в конечный файл? Цели этого кода - выбрать строки, удовлетворяющие определенным критериям, скопировать и вставить их в другую книгу. Код показан ниже: 


 

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

Ответы [ 2 ]

0 голосов
/ 10 июля 2020

Я переделал код для вас, так как основная проблема была связана с al oop, в котором на самом деле нет необходимости. Лучший / быстрый способ применить эти критерии и извлечь данные - использовать фильтр для их применения, поэтому скопируйте видимые ячейки без скрытых (несоответствующих) строк, а затем откройте второй файл, в котором вам нужно пройти информацию, найдите следующую пустую строку под выделением и вставьте все строки сразу. Я вставляю код ниже (с комментариями), а также сохранил zip-файл с 3 файлами (код, информация, база данных), которые могут отражать ваши рабочие файлы, ссылка ниже.

Код 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

Если решение вам подходит, считайте его решением. С уважением!

0 голосов
/ 09 июля 2020

Это действительно простой и c базовый способ, который я постоянно использую для копирования данных в новые книги. В этом примере я копирую именованный диапазон под названием «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
...