Column headers being copied over

[Damian37]

Hello all,
I've written some VBA code to copy column headers and random selected records on to a new worksheet. However, the data that is being copied is overwriting the column headers. I've tried a few things to have the data pasted starting on the second row, but I've been unsuccessful thus far. I was hoping someone can take a look at my code to see if someone can figure out why the column headers are being overwritten. Any and all help is much appreciated. The code I have is below:

Sub Filter_by_month()
'
' Filter_by_month Macro
    Sheets("FILENAME").Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterLastMonth, _
    Operator:=xlFilterDynamic

End Sub
Sub CreateSheet()
Sheets.Add After:=Sheets(Sheets.Count)
End Sub


Sub Copy_Header()
Application.ScreenUpdating = False
Dim i As Long

    For i = 2 To Sheets.Count
        Sheets("FILENAME").Rows(1).Copy Destination:=Sheets("Sheet1").Rows(1)
    Next
Sheets("Sheet1").Cells(1, 1).Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sub Copy()
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, k As Long
Dim RowNb As Long
Dim s As String
Sheets("FILENAME").Activate


Application.ScreenUpdating = False
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    s = i & ":" & i
    If IsEmpty(Cells(i, 1).Value) Then
         Rows(s).EntireRow.Hidden = False
    End If
Next
Application.ScreenUpdating = True
    
    
    Sheets("FILENAME").Activate
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = LastRow * 0.1
    'NbRows = IIf(LastRow < 200, LastRow * 0.1, 10)
    ReDim RowList(2 To NbRows)
    k = 1
    For i = 2 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To k
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(k) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet1").Cells(k, "A")
        k = k + 1
NextStep:
    Next i
End Sub

Thank you,
D.

 

[Damian37]

Hello all,
I've figured out how to stop my copied data from overwriting my column headers, however, now I'm recieving a Run-time error '9': Subscript out of range when I attempt to run my code for the current month. The only difference within my code is:

Sheets("FILENAME").Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
    Operator:=xlFilterDynamic

The error pertains to this line of code that is highlighted when I click on the debug button:

If (RowList(J) = RowNb) Then GoTo NextStep

The code works just fine for the previous month so I'm not sure why it wouldn't work for the current month since it's practically the same code. Anyone have any ideas?

The full new code to avoid the headers from being copied is below. This code pertains to the previous month:

Sub Filter_by_Last_month()
'
' Filter_by_month Macro
    Sheets("FILENAME").Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterLastMonth, _
    Operator:=xlFilterDynamic


'Sub CreateSheet()
Sheets.Add After:=Sheets(Sheets.Count)



'Sub Copy_Header()
Application.ScreenUpdating = False
Dim h As Long

    For h = 2 To Sheets.Count
        Sheets("FILENAME").Rows(1).Copy Destination:=Sheets("Sheet1").Rows(1)
    Next
Sheets("Sheet1").Cells(1, 1).Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

'Sub Copy()
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, k As Long
Dim RowNb As Long
Dim s As String
Sheets("FILENAME").Activate


Application.ScreenUpdating = False
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    s = i & ":" & i
    If IsEmpty(Cells(i, 1).Value) Then
         Rows(s).EntireRow.Hidden = False
    End If
Next
Application.ScreenUpdating = True
    
    
    Sheets("FILENAME").Activate
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = LastRow * 0.1
    'NbRows = IIf(LastRow < 200, LastRow * 0.1, 10)
    ReDim RowList(1 To NbRows)
    k = 2
    For i = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To k
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(k) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet1").Cells(k, "A")
        k = k + 1
NextStep:
    Next i
End Sub

The code below is for current month:

Sub Filter_by_This_month()
'
' Filter_by_month Macro
    Sheets("FILENAME").Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
    Operator:=xlFilterDynamic


'Sub CreateSheet()
Sheets.Add After:=Sheets(Sheets.Count)



'Sub Copy_Header()
Application.ScreenUpdating = False
Dim h As Long

    For h = 2 To Sheets.Count
        Sheets("FILENAME").Rows(1).Copy Destination:=Sheets("Sheet1").Rows(1)
    Next
Sheets("Sheet1").Cells(1, 1).Select
Application.CutCopyMode = False
Application.ScreenUpdating = True

'Sub Copy()
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, k As Long
Dim RowNb As Long
Dim s As String
Sheets("FILENAME").Activate


Application.ScreenUpdating = False
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    s = i & ":" & i
    If IsEmpty(Cells(i, 1).Value) Then
         Rows(s).EntireRow.Hidden = False
    End If
Next
Application.ScreenUpdating = True
    
    
    Sheets("FILENAME").Activate
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = LastRow * 0.1
    'NbRows = IIf(LastRow < 200, LastRow * 0.1, 10)
    ReDim RowList(1 To NbRows)
    k = 2
    For i = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To k
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(k) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet1").Cells(k, "A")
        k = k + 1
NextStep:
    Next i
End Sub

Anyone have any ideas why this might be happening? Thanks.