VBA Copy Rows To New Workbook - excel

Question

I am not sure why the range that i am selecting when a new work book is not being copied over. The workbook sheets are blank and i cant figure out why.
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)
When you create the new workbook it becomes active, so referring to ranges occurs in this new book, copying empty cells.
You need a reference to the current workbook
Dim wbCurrent As Workbook
Set wbCurrent = ThisWorkbook 'or ActiveWorkbook
Get references to the corresponding Worksheet(s) as well, then begin every Range or Cells use with a reference to the correct worksheet object-variable.
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)
You can go a step further and create object-variables to refer to ranges (of the different worksheets) as well. It may seem like overkill, but you need to clearly distinguish which workbook (worksheet, etc.) you are using. It will make your code easier to follow in the longer term as well.

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
Is selecting and copying empty data from the new workbook to the same empty workbook

Answer 3

I found that it's not just a question of setting the active worksheet. The range property of the "Copy" method doesn't work if the source sheet is no longer active. In order to get this to work I had to go to simply copying the values in code without using copy and replace.
I found the original code hard to follow, so I tweaked it a little. Here is what I ended up with. This should sub-divide the spreadsheet based on captions in F and copy the data in G - M to output columns 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