VBA将行复制到新的工作簿
我不确定为什么当新的工作簿不被复制时，我正在select的范围。 工作簿表是空白的，我不知道为什么。
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 Set WB = Workbooks.Add(1)
创build新工作簿时，它变为活动状态，所以在这本新书中引用范围，复制空单元格。
您需要参考当前的工作簿
Dim wbCurrent As Workbook Set wbCurrent = ThisWorkbook 'or ActiveWorkbook
获取对相应的工作表的引用，然后开始每个Range或Cells使用正确的工作表对象variables的引用。
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)
您可以更进一步，并创build对象variables来引用范围（不同的工作表）。 看起来似乎有点过分，但是您需要清楚地区分您正在使用的工作簿（工作表等）。 它将使您的代码更容易在更长的时间内跟踪。
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy Range("A1").PasteSpecial
是从新工作簿中select和复制空数据到同一个空工作簿
我发现这不仅仅是设置活动工作表的问题。 如果源表不再有效，则“复制”方法的范围属性不起作用。 为了得到这个工作，我不得不去复制代码中的值，而不使用复制和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