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

Question

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

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

当我在调试时，在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编写代码，这有助于程序员捕捉隐藏的编译错误。

你的问题的解决方案是在线路

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

所以我们在这里所做的就是去上65535行的表的最后一行（我知道以后的版本有更多的行，但这个数字是好的），然后我们说End（xlUp）这在逻辑上意味着上去这个列，直到你找到一些文本将是你的数据块的最后一行。

就在下面，我改变了Range语句的语法，它非常灵活，所以一次调用带Range的字符串（“A1：B3”），或者可以调用每个单元格有两个参数的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

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 

Answer 3

如果你只是应对数据的一列从一个工作到另一个工作表的另一列存在着很多更简单的方法正在做。 下面的代码有帮助吗？很抱歉，如果我误解你的要求......

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