将数据从一个工作簿复制到另一个工作簿时出错

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

我的源工作簿，包含722行的数据。 但代码复制只有72行。

当我在debugging的时候，在siiurcewkbk中，我可以看到722行被选中，但是在destwkb中只有72行被粘贴。

另外，我的sourcewb中的列在AK中，我希望它们被粘贴在destwb的A列中。

谁能帮我解决这个问题。

Sub Extract() Dim x As Workbook Dim y As Workbook Dim Val As Variant Dim filename As String Dim LastCell As Range Dim LastRow As Long CopyCol = Split("AK", ",") LR = Cells(Rows.Count, 1).End(xlUp).Row LC = Cells(1, Columns.Count).End(xlToLeft).Column LCell = Activewindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Address LCC = Activewindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Column lcr = Activewindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Row Set y = ThisWorkbook Dim path1, Path2 path1 = ThisWorkbook.Path Path2 = path1 & "\Downloads" Set x = Workbooks.Open(filename:=Path2 & "\Red.xlsx") For Count = 0 To UBound(CopyCol) Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & lcr) If Count = 0 Then Set CopyRange = temp Else Set CopyRange = Union(CopyRange, temp) End If Next CopyRange.Copy y.Sheets("All").Paste y.Sheets("All").Range("A4") Application.CutCopyMode = False x.Close End Sub 

anylead会有所帮助。

Answer 1

试试这个，我注意到一些无所作为的行，就我所知，因为我对代码严格。 另外我添加了一些Dim语句，因为我总是在模块的顶部使用Option Explicit编写代码，这样可以帮助程序员捕捉隐藏的编译错误。

你的问题的解决scheme是在线

  Dim rngLastCell As Excel.Range Set rngLastCell = Range(CopyCol(Count) & "65535").End(xlUp) 

所以我们在这里做的是去65535行（我知道后面的版本有更多的行，但这个数字是好的）表的最后一行，然后我们说结束（xlUp），这在逻辑上意味着上去这个专栏，直到你find一些将成为数据块底部的文本。

就在下面，我改变了Range语句的灵活性，所以我们可以调用一个像Range（“A1：B3”）这样的string，或者可以调用每个单元格有两个参数的Range，Range（Range（“A1 “），范围（” B3" ））。

 Option Explicit Sub Extract() Dim x As Workbook Dim y As Workbook Dim Val As Variant Dim filename As String Dim LastCell As Range Dim LastRow As Long Dim CopyCol CopyCol = Split("AK", ",") '* LR is never used 'LR = Cells(Rows.Count, 1).End(xlUp).Row '* lc is never used 'lc = Cells(1, Columns.Count).End(xlToLeft).Column '* LCell is never used 'LCell = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Address '* LCC is never used 'LCC = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Column Dim lcr lcr = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Row Set y = ThisWorkbook Dim path1, Path2 path1 = ThisWorkbook.Path Path2 = path1 & "\Downloads" Set x = Workbooks.Open(filename:=Path2 & "\Red.xlsx") Dim Count As Long For Count = 0 To UBound(CopyCol) Dim rngLastCell As Excel.Range Set rngLastCell = Range(CopyCol(Count) & "65535").End(xlUp) Dim temp As Excel.Range 'Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & lcr) Set temp = Range(CopyCol(Count) & "1", rngLastCell) If Count = 0 Then Dim CopyRange As Excel.Range Set CopyRange = temp Else Set CopyRange = Union(CopyRange, temp) End If Next CopyRange.Copy y.Sheets("All").Paste y.Sheets("All").Range("A4") Application.CutCopyMode = False x.Close End Sub 

Answer 2

如果您只是将一个工作表中的一列数据应用到另一个工作表中的另一列，则可以使用更简单的方法。 下面的代码有帮助吗？ 对不起，如果我误解了你的要求…

 Sub Extract() Dim Path2 As String '** path to the workbook you want to copy to *** Dim X As Workbook '*** WorkBook to copy from **** Dim Y As Workbook '** WorkBook to copy to Set X = ActiveWorkbook '** This workbook **** Path2 = "C:\test" '** path of book to copy to Set Y = Workbooks.Open(filename:=Path2 & "\Red.xlsx") X.Sheets("From").Range("A:A").Copy Destination:=Y.Sheets("ALL").Range("A1") Application.CutCopyMode = False Y.Save Y.Close End Sub 

Answer 3

CopyCol = Split("AK", ",")是Array("AK") …为什么？
For Count = 0 To UBound(CopyCol) ... Next从0运行到0（一个周期）。

把它放在一个较短的子，我推荐这样的东西：

 Sub Extract() Dim path1 As String path1 = ThisWorkbook.Path & "\Downloads" Dim CopyCol As String CopyCol = "AK" With Workbooks.Open(filename:=path1 & "\Red.xlsx") With .ActiveSheet .Range(.Cells(1, CopyCol), .Cells(.Rows.Count, CopyCol).End(xlUp)).Copy ThisWorkbook.Sheets("All").Range("A4") End With .Close End With End Sub