VBA Copy Rows To New Workbook

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