VBA Error - Range Copy Command not consistent?

[Johnny Thunder]

Hello all, I am truly stumped on this and need some guidance from the community.

I have some code that creates a unique list of values from a report and then uses a variable from that unique list "Count" to determine how many times to resize a range, essentially copy rows 1:21 x amount of times.

I am seeing something truly weird and not sure why it is happening. I am hoping another set of eyes may find the error in my code that is causing this.

So, if I trigger the code manually, stepping thru it works without error, but if I run from a macro button it actually only highlights row 1, range E1:T1????? I don't even have any commands with that range so not sure what is happening.

I have updated the error line recently from ws2.rows("1:21").Copy with no change, still get the same error inconsistently.

Here is the code - Error line is commented and towards the bottom.

'--------------------------------------------------------------------------------
'--- Creates Schedule Blocks Based on Count of FY Release
'--------------------------------------------------------------------------------
Sub CreateScheduleBlocks()

Dim ws1, ws2, ws3 As Worksheet
Dim vaData, aOutput() As Variant
Dim colUnique     As Collection
Dim i, LastR1, LastR2, Block, J, k, x, l As Long
Dim Count, BlockCode As String
Dim r   As Range, Cell As Range

Set ws1 = Sheets("Schedule Report")
Set ws2 = Sheets("Data Entry")
Set ws3 = Sheets("Lookups")

LastR1 = ws1.Cells(Rows.Count, "Q").End(xlUp).Row   'Lastrow of Schedule Report
LastR2 = ws3.Cells(Rows.Count, "U").End(xlUp).Row   'Lastrow of Lookups Block Count

ws1.Columns("G:P").NumberFormat = "mmm-yy"  'Formats all dates on Sched Report

'--------------------------Builds Unique Block # Data on Lookups-------------------------
                            'Put the data in an array
                            vaData = ws1.Range("Q2:Q" & LastR1).Value
                        
                            'Create a new collection
                            Set colUnique = New Collection
                        
                            'Loop through the data
                            For i = LBound(vaData, 1) To UBound(vaData, 1)
                                'Collections can't have duplicate keys, so try to
                                'add each item to the collection ignoring errors.
                                'Only unique items will be added
                                On Error Resume Next
                                    colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
                                On Error GoTo 0
                            Next i
                        
                            'size an array to write out to the sheet
                            ReDim aOutput(1 To colUnique.Count, 1 To 1)
                        
                            'Loop through the collection and fill the output array
                            For i = 1 To colUnique.Count
                                aOutput(i, 1) = colUnique.item(i)
                            Next i
                        
                        ws3.Range("U2:W" & LastR2).ClearContents
                        
                            'Write the unique values to column
                            ws3.Range("V1").Value = "Unique Release Year"
                            ws3.Range("V2").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
                            
                            LastR2 = ws3.Cells(Rows.Count, "V").End(xlUp).Row   'Redefines the New LastR
                                ws3.Range("U1").Value = "Counter"
                                        ws3.Range("U2:U" & LastR2).Formula = "=""Block "" & ROW()-1"
                                            ws3.Range("W1").Value = "Row Count"
                                                ws3.Range("W2:W" & LastR2).Formula = "=COUNTIF('Schedule Report'!Q:Q,V2)"
                                                ws3.Range("U2:W" & LastR2).Value = ws3.Range("U2:W" & LastR2).Value 'Hardcodes formulas
'--------------------------Builds Unique Block # Data on Lookups-------------------------
                
Count = Application.WorksheetFunction.CountA(ws3.Range("V2:V" & LastR2)) 'Defines how many times to copy the block of data - Usually 4

Dim Srow As Long: Srow = Count

ws2.Range("A1:AR21").EntireRow.Copy '<-----------------------------------------------------------------------------This line is the problem-------------------------------------------------------

ws2.Rows(22).Resize(21 * (Count - 1)).PasteSpecial xlPasteAllUsingSourceTheme

Application.CutCopyMode = False
  
    With ws3    'Drops in Block Names
        x = .Cells(.Rows.Count, 21).End(xlUp).Row   'was 19
        For Each r In .Cells(2, 21).Resize(x - 1).SpecialCells(xlCellTypeConstants) 'only looks as cells with values    - Might need to change to 21
            If r.Value <> "" Then
                ws2.Cells(Srow, 1).Value = r.Value
                Srow = Srow + 21
            End If
        Next r
    End With
         
End Sub

 

[rlv01]

If it was me, the first thing I'd do would be to add some code just before the copy statement to closely inspect the range I was trying to copy:

    Dim Srow As Long: Srow = Count

    Dim rngTest As Range   '<-- start debug code 

    Debug.print ThisWorkbook.name
    Debug.Print ActiveSheet.Name
    Debug.Print ActiveSheet.Parent.Name
 
    Debug.Print ws2.Name
    Debug.Print ws2.Parent.Name

    Set rngTest = ws2.Range("A1:AR21")
    Debug.Print TypeName(rngTest)
    Debug.Print rngTest.Address

    Set rngTest = ws2.Range("A1:AR21").EntireRow
    Debug.Print TypeName(rngTest)
    Debug.Print rngTest.Address
    
    Application.CutCopyMode = False                   'clear the clipboard
    R.EntireRow.Copy
    Application.CutCopyMode = False                   'clear the clipboard again

    ws2.Range("A1:AR21").EntireRow.Copy               '<-----------------------------------------------------------------------------This line is the problem-------------------------------------------------------

If that does not bear fruit, it looks like you could comment out large chunks of your code to reduce it to just the essentials needed to perform a copy, then if that works you can methodically remove the comments a bit at a time to see where the problem is.

'--------------------------------------------------------------------------------
'--- Creates Schedule Blocks Based on Count of FY Release
'--------------------------------------------------------------------------------
Sub CreateScheduleBlocks()

Dim ws1, ws2, ws3 As Worksheet
Dim vaData, aOutput() As Variant
Dim colUnique     As Collection
Dim i, LastR1, LastR2, Block, J, k, x, l As Long
Dim Count, BlockCode As String
Dim r   As Range, Cell As Range

Set ws1 = Sheets("Schedule Report")
Set ws2 = Sheets("Data Entry")
'Set ws3 = Sheets("Lookups")
'
'LastR1 = ws1.Cells(Rows.Count, "Q").End(xlUp).Row   'Lastrow of Schedule Report
'LastR2 = ws3.Cells(Rows.Count, "U").End(xlUp).Row   'Lastrow of Lookups Block Count
'
'ws1.Columns("G:P").NumberFormat = "mmm-yy"  'Formats all dates on Sched Report
'
''--------------------------Builds Unique Block # Data on Lookups-------------------------
'                            'Put the data in an array
'                            vaData = ws1.Range("Q2:Q" & LastR1).Value
'
'                            'Create a new collection
'                            Set colUnique = New Collection
'
'                            'Loop through the data
'                            For i = LBound(vaData, 1) To UBound(vaData, 1)
'                                'Collections can't have duplicate keys, so try to
'                                'add each item to the collection ignoring errors.
'                                'Only unique items will be added
'                                On Error Resume Next
'                                    colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
'                                On Error GoTo 0
'                            Next i
'
'                            'size an array to write out to the sheet
'                            ReDim aOutput(1 To colUnique.Count, 1 To 1)
'
'                            'Loop through the collection and fill the output array
'                            For i = 1 To colUnique.Count
'                                aOutput(i, 1) = colUnique.Item(i)
'                            Next i
'
'                        ws3.Range("U2:W" & LastR2).ClearContents
'
'                            'Write the unique values to column
'                            ws3.Range("V1").Value = "Unique Release Year"
'                            ws3.Range("V2").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
'
'                            LastR2 = ws3.Cells(Rows.Count, "V").End(xlUp).Row   'Redefines the New LastR
'                                ws3.Range("U1").Value = "Counter"
'                                        ws3.Range("U2:U" & LastR2).Formula = "=""Block "" & ROW()-1"
'                                            ws3.Range("W1").Value = "Row Count"
'                                                ws3.Range("W2:W" & LastR2).Formula = "=COUNTIF('Schedule Report'!Q:Q,V2)"
'                                                ws3.Range("U2:W" & LastR2).Value = ws3.Range("U2:W" & LastR2).Value 'Hardcodes formulas
''--------------------------Builds Unique Block # Data on Lookups-------------------------
'
'Count = Application.WorksheetFunction.CountA(ws3.Range("V2:V" & LastR2)) 'Defines how many times to copy the block of data - Usually 4
'
'Dim Srow As Long: Srow = Count

ws2.Range("A1:AR21").EntireRow.Copy '<-----------------------------------------------------------------------------This line is the problem-------------------------------------------------------

ws2.Rows(22).Resize(21 * (Count - 1)).PasteSpecial xlPasteAllUsingSourceTheme

Application.CutCopyMode = False
  
'    With ws3    'Drops in Block Names
'        x = .Cells(.Rows.Count, 21).End(xlUp).Row   'was 19
'        For Each r In .Cells(2, 21).Resize(x - 1).SpecialCells(xlCellTypeConstants) 'only looks as cells with values    - Might need to change to 21
'            If r.Value <> "" Then
'                ws2.Cells(Srow, 1).Value = r.Value
'                Srow = Srow + 21
'            End If
'        Next r
'    End With
'
End Sub

 

[Johnny Thunder]

Thank you for the suggestions, I am putting them in place now to try it out.