將數據從一個工作簿複製到另一個工作簿時出錯

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