Excel VBA将行复制到新工作簿_Excel_Vba

Excel VBA将行复制到新工作簿

excel vba

Excel VBA将行复制到新工作簿,excel,vba,Excel,Vba,我不知道为什么我选择的范围，当一本新的工作手册没有被复制。工作簿是空白的，我不知道为什么 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

我不知道为什么我选择的范围，当一本新的工作手册没有被复制。工作簿是空白的，我不知道为什么

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

创建新工作簿时，它将处于活动状态，因此在本新书中会引用范围，即复制空单元格

您需要对当前工作簿的引用

Dim wbCurrent As Workbook

Set wbCurrent = ThisWorkbook    'or ActiveWorkbook

同时获取对相应工作表的引用，然后开始每个

范围

或

单元格

的使用，并引用正确的工作表对象变量

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)

您还可以更进一步，创建对象变量来引用（不同工作表的）范围。这似乎有些过分，但您需要清楚地区分您正在使用的工作簿（工作表等）。从长远来看，这将使您的代码更易于遵循

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

正在从新工作簿中选择空数据并将其复制到同一个空工作簿中

我发现这不仅仅是设置活动工作表的问题。如果源工作表不再处于活动状态，“Copy”方法的range属性将不起作用。为了让它工作，我必须简单地复制代码中的值，而不使用copy和replace

我发现原来的代码很难理解，所以我对它做了一些调整。这就是我的结局。这应该根据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

Sub NB（）
作为字符串的Dim strDT
将WB设置为工作簿
变暗范围（10）作为范围
变光高度（10）为整数
Dim名称（10）作为字符串
暗排一样长
Dim maxRow尽可能长
暗顶和长顶一样
暗底一样长
作为整数的Dim-iData
我的书很长
设置objWS=CreateObject（“WScript.Shell”）
strDT=objWS.SpecialFolders（“桌面”）和“\Book1”
如果Len（Dir（strDT，vbDirectory））=0，则
MsgBox“没有这样的目录”，vbCritical
出口接头
如果结束
iData=0
maxRow=范围（“G”和65536）.结束（xlUp）.行
如果（maxRow<2），则
MsgBox（“G列中没有数据”）
出口接头
如果结束
'第一个循环存储源范围
对于行=1到maxRow
如果（不是空的（范围（“F”和行）），则
如果（iData>0），则
设置范围（iData）=范围（“G”和顶部&“：”和“M”和底部）
高度（iData）=底部-顶部
如果结束
iData=iData+1
顶部=行+1
底部=行+1
名称（iData）=范围（“F”和行）。值2
其他的
底部=行+1
如果结束
下一个
设置范围（iData）=范围（“G”和顶部&“：”和“M”和底部）
高度（iData）=底部-顶部
'第二个循环将值复制到输出范围。
对于iBook=1到iData
'为第一个值制作单页工作簿
设置WB=工作簿。添加（1）
范围（“A1:G”和高度（iBook））。值=范围（iBook）。值2
WB.SaveAs（strDT&“\”&名称（iBook）&“.xls”）
WB.关闭
下一个
端接头
函数IsEmpty（ByVal copyRange作为范围）
IsEmpty=（Application.CountA（copyRange）=0）
端函数

您应该尽量避免复制粘贴，直接将空工作表的值设置为所需的值。我需要将数据分离到相应的工作表中。我提供了一个链接，指向谷歌文档的示例数据：。数据1工作簿上只需要有数据信息1。一路向下都是一样的，但当前代码只是在向下读取时复制过来，没有相应地分离信息。当然！因此，当我在处理它时，无论出于何种原因，如果在进行复制时尝试调用源代码上的“Range”方法，它都会抛出错误，但在它是活动工作表时调用它非常有效。因此，在进行复制之前，先循环源工作表，找出SourceRange1、SourceRange2、SourceRange3等。然后，您可以使用新创建的目标上的Range属性作为活动工作表，使用这些范围单独浏览并创建输出工作簿。好的，我更新了代码，使之与书本分开。

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