从一个工作簿提取数据并将其复制到另一个工作簿

Question

我试图将数据从一个工作簿复制到另一个工作簿。

我通过互联网搜索，并提出了下面的代码。代码中没有错误。

代码工作正常，但问题是，它打开两个表，但不复制目标工作表中的数据。

在下面的代码中，我认为x是源表单，y是目标表单。

有人可能会建议，我错了什么，我不能复制的原因是什么。

Sub test() 
Dim x As Workbook 
Dim y As Workbook 
Dim val As Variant 
Dim filename As String 


Set x = Workbooks.Open("D:\Mikz\xxx.xlsx") 

Set y = Sheets("Sheet1").Select 
val = x.Sheets("Sheet2").Range("A1").Value 
y.Sheets("Sheet1").Range("A1").Value = val 

x.Close 

End Sub 

Answer 1

尝试：

Sub test() 
Dim wb As Workbook 
Dim sht As Worksheet, sht2 As Worksheet 

Set wb = Workbooks.Open("Filename") 
Set sht = wb.Worksheets("Sheet2") 
Set sht2 = ThisWorkbook.Worksheets("Sheet1") 

sht2.Range("A1").Value = sht.Range("A1").Value 

wb.Close 
End Sub 

但它应该抛出语法错误和之前类型不匹配。不要使用.Select，它不需要任何功能或任务，它可以不用。

Answer 2

原因你的错误，在于以下部分：

Dim y As Workbook 
Set y = Sheets("Sheet1").Select 

您定义y为工作簿，但试图将Worksheet对象分配给它，您添加Select出于某种原因，这是挑衅不推荐。

它应该是（如果工作簿是打开的）：

Set y = Workbooks("YourBookName") 

你的代码的其余部分会工作得很好。

---

---

然而，读您的文章，我觉得你的意思来定义y As Worksheet。

然后你的代码的其余部分应该是：

Set y = Sheets("Sheet1") 
val = x.Sheets("Sheet2").Range("A1").Value 
y.Range("A1").Value = val 

---

编辑1：更新后的代码（根据PO的新数据）

Option Explicit 

Sub test() 

Dim x As Workbook 
Dim y As Workbook 
Dim Val As Variant 
Dim filename As String 

Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies) 
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx") 

Val = x.Sheets("Sheet2").Range("A1").Value 
y.Sheets("Sheet1").Range("A1").Value = Val 

x.Close 

End Sub 

---

编辑2：代码复制列A：E直到最后一行有数据

Option Explicit 

Sub test() 

Dim x As Workbook 
Dim y As Workbook 
Dim Val As Variant 
Dim filename As String 
Dim LastCell As Range 
Dim LastRow As Long 

Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies) 
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx")  
With x.Sheets("Sheet2") 
    ' use the find method to get the last row in column A:E 
    Set LastCell = .Columns("A:E").Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False) 
    If Not LastCell Is Nothing Then ' find was successful 
     LastRow = LastCell.Row ' get last Row with data 
    End If 

    Val = .Range("A1:E" & LastRow).Value ' save range in 2-D array 
End With 

' resize the range from A1 through column E and the last row with data in copied workbook 
y.Sheets("Sheet1").Range("A1").Resize(LastRow, 5).Value = Val 

x.Close 

End Sub