VBA Not Pasting Values into New Workbook Sheet

Question

I created this script that applies conditional formatting to three pivot tables and attempts to save the results of each table into it's own tab in a new workbook.

Here is my code:

Sub conditional_formatting():

    ' Set dimensions
    Dim i As Long
    Dim rowCount As Long
    Dim numOpen As Range
    Dim Ws As Worksheet
    Dim xWs1, xWs2, xWs3 As Worksheet
    Dim NewBook As Workbook
    Dim Nbs1, Nbs2, Nbs3 As Worksheet
    
    Set NewBook = Workbooks.Add
    With NewBook
      Set Nbs1 = NewBook.Sheets("Sheet1")
      NewBook.Sheets.Add.Name = "Sheet2"
      Set Nbs2 = NewBook.Sheets("Sheet2")
      NewBook.Sheets.Add.Name = "Sheet3"
      Set Nbs3 = NewBook.Sheets("Sheet3")

   End With

    ' loop through final report sheets
    For Each Ws In ActiveWorkbook.Worksheets
    
        ' only loop through lic, loss loc, and reallocate reports
        If Ws.Index > 4 And Ws.Index < 8 Then
            
            If Ws.Index = 5 Then
            
            ' get the row number of the last row with data
            rowCount = Cells(Rows.Count, "L").End(xlUp).Row
        
                For i = 14 To rowCount
            
                    ' Store number of weeks open in working cell
                      Set numOpen = Range("L" & i)
            
                    ' Apply RAG conditional formatting
                     Select Case numOpen.Value
                       Case Is > 4
                          numOpen.Interior.ColorIndex = 3
                       Case Is > 2
                          numOpen.Interior.ColorIndex = 44
                       Case Else
                          numOpen.Interior.ColorIndex = 43
                     End Select
            
                Next i
        
           Ws.Range("A13:" & "L" & rowCount).Copy
           Nbs1.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
                Nbs1.Name = "(lic)"
        
            ElseIf Ws.Index = 6 Then
            
            ' get the row number of the last row with data
            rowCount = Cells(Rows.Count, "L").End(xlUp).Row
            
                For i = 11 To rowCount
            
                    ' Store number of weeks open in working cell
                      Set numOpen = Range("L" & i)
            
                    ' Apply RAG conditional formatting
                     Select Case numOpen.Value
                       Case Is > 4
                          numOpen.Interior.ColorIndex = 3
                       Case Is > 2
                          numOpen.Interior.ColorIndex = 44
                       Case Else
                          numOpen.Interior.ColorIndex = 43
                     End Select
            
                Next i
            
              Ws.Range("A10:" & "L" & rowCount).Copy
              Nbs2.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
                Nbs2.Name = "(loss loc)"
     
            Else
            
            ' get the row number of the last row with data
            rowCount = Cells(Rows.Count, "L").End(xlUp).Row
            
                For i = 13 To rowCount
            
                    ' Store number of weeks open in working cell
                      Set numOpen = Range("L" & i)
            
                    ' Apply RAG conditional formatting
                     Select Case numOpen.Value
                       Case Is > 4
                          numOpen.Interior.ColorIndex = 3
                       Case Is > 2
                          numOpen.Interior.ColorIndex = 44
                       Case Else
                          numOpen.Interior.ColorIndex = 43
                     End Select
            
                Next i
             Ws.Range("A12:" & "L" & rowCount).Copy
             Nbs3.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
                Nbs3.Name = "(reallocate)"
                     
            End If

        End If
        
    Next Ws

  
NewBook.SaveAs Filename:="C:\Test1"

MsgBox ("Done")
    
End Sub

The script does not give me any errors, and it is successfully applying the conditional formatting, in addition to creating the correct tabs with the exception of renaming them as well.

For some reason, it's not actually pasting any values in the new workbook.

Any ideas?

Answer 1

I would try extracting the common code into separate subs.

Some other fixes included, such as qualifying every range with a worksheet object.

Sub conditional_formatting():

    ' Set dimensions
    Dim rowCount As Long
    Dim Ws As Worksheet
    Dim NewBook As Workbook
    Dim Nbs1 As Worksheet, Nbs2 As Worksheet, Nbs3 As Worksheet
    Dim wbSrc As Workbook
    
    Set wbSrc = ActiveWorkbook '<<<<remember this workbook
    
    Set NewBook = Workbooks.Add
    With NewBook
        Set Nbs1 = .Sheets("Sheet1")
        .Sheets.Add.Name = "Sheet2" '<< use your With here...
        Set Nbs2 = .Sheets("Sheet2")
        .Sheets.Add.Name = "Sheet3"
        Set Nbs3 = .Sheets("Sheet3")
    End With

    ' loop through final report sheets
    For Each Ws In wbSrc.Worksheets
        
        rowCount = Ws.Cells(Ws.Rows.Count, "L").End(xlUp).Row 'only need this once
        
        If Ws.Index = 5 Then
            FormatRange Ws.Range("L14:L" & rowCount)
            CopyValues Ws.Range("A13:L" & rowCount), Nbs1.Range("A1")
            Nbs1.Name = "(lic)"
        ElseIf Ws.Index = 6 Then
            FormatRange Ws.Range("L11:L" & rowCount)
            CopyValues Ws.Range("A10:L" & rowCount), Nbs2.Range("A1")
            Nbs2.Name = "(loss loc)"
        ElseIf Ws.Index = 7 Then
            FormatRange Ws.Range("L13:L" & rowCount)
            CopyValues Ws.Range("A12:L" & rowCount), Nbs3.Range("A1")
            Nbs3.Name = "(reallocate)"
        End If
    
    Next Ws

    NewBook.SaveAs Filename:="C:\Test1"
    MsgBox ("Done")
    
End Sub

'copy values from rngFrom into rngTo (resizing as necessary)
Sub CopyValues(rngFrom As Range, rngTo As Range)
    With rngFrom
        rngTo.Cells(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With
End Sub

'loop over and format a range according to cell values
Sub FormatRange(rng As Range)
    Dim c As Range
    For Each c In rng.Cells
        Select Case c.Value
          Case Is > 4
             c.Interior.ColorIndex = 3
          Case Is > 2
             c.Interior.ColorIndex = 44
          Case Else
             c.Interior.ColorIndex = 43
        End Select
    Next c
End Sub