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