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

我发现它不仅仅是设置活动工作表的问题。＆＃34;复制＆＃34;的范围属性如果源表不再有效，则方法不起作用。为了使其工作，我不得不简单地复制代码中的值而不使用复制和替换。

我发现原始代码难以理解，所以我稍微调整了一下。这就是我最终的结果。这应该根据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

VBA复制行到新工作簿

3 个答案: