VBA將行復制到新工作簿

Question

我不確定爲什麼當新工作簿未被複制時選擇的範圍。工作簿表空白，我不知道爲什麼。

Sub NB() 
    Dim X 
    Dim copyRange 
    Dim lngCnt As Long 
    Dim strDT As String 
    Dim strNewBook As String 
    Dim objWS As Object 
    Dim WB As Workbook 
    Dim bNewBook As Boolean 
    Dim topRow As Integer 

    topRow = -1 

    Set objWS = CreateObject("WScript.Shell") 
    strDT = objWS.SpecialFolders("Desktop") & "\Book1" 
    If Len(Dir(strDT, vbDirectory)) = 0 Then 
     MsgBox "No such directory", vbCritical 
     Exit Sub 
    End If 
    X = Range([f1], Cells(Rows.Count, "f").End(xlUp)).Value2 
    For lngCnt = 1 To UBound(X, 1) 
     If Len(X(lngCnt, 1)) > 0 Then 
      If (topRow = -1) Then 
       topRow = lngCnt 
      Else 
       If Not bNewBook Then 
        'make a single sheet workbook for first value 
        Set WB = Workbooks.Add(1) 
        copyRange = Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Value2 

        'find a way to copy copyRange into WB 
        Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select 
        Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy 
        Range("A1").PasteSpecial 


        WB.SaveAs strDT & "\" & X(topRow, 1) & ".xls" 
        strNewBook = WB.FullName 
        WB.Close 
        bNewBook = True 
       Else 
        Set WB = Workbooks.Add(1) 
        copyRange = Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Value2 

        'find a way to copy copyRange into WB 
        Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select 
        Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy 
        Range("A1").PasteSpecial 
        WB.SaveAs strDT & "\" & X(topRow, 1) & ".xls" 
        WB.Close 

       End If 
       topRow = lngCnt 
      End If 
     End If 
    Next 

Answer 1

Set WB = Workbooks.Add(1) 

當你創建它成爲活躍的新的工作簿，所以參考範圍發生在這本新書，複製空單元格。

你需要一個參照當前工作簿

Dim wbCurrent As Workbook 

Set wbCurrent = ThisWorkbook 'or ActiveWorkbook 

到相應的工作表（S）獲取引用爲好，然後開始以正確的工作表對象變量的引用的每個Range或Cells使用。

Dim wbCurrent As Workbook 
Dim wsNew As Worksheet 
Dim wsCurrent As Worksheet 

Set wbCurrent = ThisWorkbook 
Set wsCurrent = wbCurrent.Worksheets("Whatever Name") 

Set WB = Workbooks.Add(1) 
Set wsNew = WB.Worksheets(1) 

您可以更進一步並創建對象變量來引用（不同工作表的）範圍。這看起來似乎過分了，但你需要清楚地區分你正在使用的工作簿（工作表等）。它將使您的代碼更容易在更長期內遵循。

Answer 2

Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select 
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy 
Range("A1").PasteSpecial 

是選擇和新的工作簿中的空數據複製到同一工作簿空

Answer 3

我發現，它不只是一個設置活動工作表的問題。如果源表不再有效，則「複製」方法的範圍屬性不起作用。爲了得到這個工作，我不得不去複製代碼中的值而不使用複製和替換。

我發現原始代碼難以遵循，所以我調整了一下。這是我最終的結果。這應該根據F中的字幕細分電子表格，並將G-M中的數據複製到輸出列A-G

Sub NB() 
    Dim strDT As String 
    Dim WB As Workbook 
    Dim Ranges(10) As Range 
    Dim Height(10) As Integer 
    Dim Names(10) As String 
    Dim row As Long 
    Dim maxRow As Long 
    Dim top As Long 
    Dim bottom As Long 
    Dim iData As Integer 
    Dim iBook As Long 


    Set objWS = CreateObject("WScript.Shell") 
    strDT = objWS.SpecialFolders("Desktop") & "\Book1" 
    If Len(Dir(strDT, vbDirectory)) = 0 Then 
     MsgBox "No such directory", vbCritical 
     Exit Sub 
    End If 

    iData = 0 
    maxRow = Range("G" & 65536).End(xlUp).row 
    If (maxRow < 2) Then 
     MsgBox ("No Data was in the G column") 
     Exit Sub 
    End If 

      ' The first loop stores the source ranges 
    For row = 1 To maxRow 
     If (Not IsEmpty(Range("F" & row))) Then 
      If (iData > 0) Then 
      Set Ranges(iData) = Range("G" & top & ":" & "M" & bottom) 
      Height(iData) = bottom - top 
      End If 
      iData = iData + 1 
      top = row + 1 
      bottom = row + 1 
      Names(iData) = Range("F" & row).Value2 
     Else 
      bottom = row + 1 
     End If 
    Next 
    Set Ranges(iData) = Range("G" & top & ":" & "M" & bottom) 
    Height(iData) = bottom - top 

      ' The second loop copies the values to the output ranges. 
    For iBook = 1 To iData 
     'make a single sheet workbook for first value 
     Set WB = Workbooks.Add(1) 
     Range("A1:G" & Height(iBook)).Value = Ranges(iBook).Value2 
     WB.SaveAs (strDT & "\" & Names(iBook) & ".xls") 
     WB.Close 
    Next 
End Sub 

Function IsEmpty(ByVal copyRange As Range) 
    IsEmpty = (Application.CountA(copyRange) = 0) 
End Function