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

同时获取对相应工作表的引用，然后在每次使用 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