Help editing this macro so if theres two much data it starts a new tab

[tonywatsonhelp]

Hi Everyone,
I have a macro that works great, its purpose is to go to a folder open each CSV file and filter the data and copy it into this document,
it all works great until we get to the part where its coping more data then i have rows left, at which point it errors out and because i have a on error resume next, it just doesn't paste the data,

so I need help, i dont mid how its done but basicly i need the macro edited so if the number of rows copied are more than the empty row in sheet "Submissions" it creates a new tab and paste it in there and so on if it fills up again does the same.

so instead of one tab i get several tabs, not worried about headers or filling up the tabs happy if theres 400,000 rows and it copies 500,000 rows to start anew sheet, dont care what the new sheets are called as long as it works

I hope thats clear, but to summories again

macro below needs chnaging so that if it copies more rows then are left in the sheet to paste into it starts a new tab and continues adding new tabs until all data is copied over.

heres my code please help if you can

Tony

Sub ImportWorksheets()
Application.DisplayAlerts = False
RelativePath = ThisWorkbook.Path & "\"


Dim sFile As String
Dim wbSource As Workbook
Dim wbArchive As String, wbNew As String, KillFile As String

sFile = Dir(RelativePath & "*.csv")
Do Until sFile = ""

Set wbSource = Workbooks.Open(RelativePath & sFile)
KillFile = wbSource.Path & "\" & wbSource.Name

On Error Resume Next

If ActiveSheet.Range("G1") = "isrcs" Then
    LR1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    ActiveSheet.Range("H1") = "ISRC"
    ActiveSheet.Range("H2:H" & LR1).FormulaR1C1 = "=LEFT(RC[-2],2)"

    ActiveSheet.Range("$A$1:$H$" & LR1).AutoFilter Field:=8, Criteria1:="GB"
    ActiveSheet.Range("$A$1:$H$" & LR1).AutoFilter Field:=5, Criteria1:=""

    ActiveSheet.Range("$A$2:$H$" & LR1).SpecialCells(xlCellTypeVisible).Copy

    ThisWorkbook.Activate
    LR2 = Sheets("Production").Cells(Rows.Count, "A").End(xlUp).Row + 1

    Sheets("Production").Range("A" & LR2).PasteSpecial xlPasteValues

Else
    'Save Archive
    wbArchive = RelativePath & "Archived\" & wbSource.Name
    wbSource.SaveAs Filename:=wbArchive

End If

'Delete Sourcebook
wbSource.Close False
Kill KillFile

sFile = Dir()
Loop
Set wbSource = Nothing
Application.DisplayAlerts = True

End Sub

 

[JLGWhiz]

this is untested, so post back with problems related to the modification in red font.

Sub ImportWorksheets()
Application.DisplayAlerts = False
RelativePath = ThisWorkbook.Path & "\"
Dim sFile As String
Dim sh As Worksheet
Dim wbSource As Workbook
Dim wbArchive As String, wbNew As String, KillFile As String
sFile = Dir(RelativePath & "*.csv")
Do Until sFile = ""
Set wbSource = Workbooks.Open(RelativePath & sFile)
Set sh = ThisWorkbook.Sheets("Production")
KillFile = wbSource.Path & "\" & wbSource.Name
On Error Resume Next
If ActiveSheet.Range("G1") = "isrcs" Then
    LR1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    ActiveSheet.Range("H1") = "ISRC"
    ActiveSheet.Range("H2:H" & LR1).FormulaR1C1 = "=LEFT(RC[-2],2)"
    ActiveSheet.Range("$A$1:$H$" & LR1).AutoFilter Field:=8, Criteria1:="GB"
    ActiveSheet.Range("$A$1:$H$" & LR1).AutoFilter Field:=5, Criteria1:=""
    ActiveSheet.Range("$A$2:$H$" & LR1).SpecialCells(xlCellTypeVisible).Copy
    ThisWorkbook.Activate
    LR2 = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
    If (LR1 - 1) < (sh.Rows.Count - LR2) Then
        sh.Range("A" & LR2).PasteSpecial xlPasteValues
    Else
        Set sh = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        sh.Name = "Production" & sh.Index
        sh.Range("A1").PasteSpecial xlPasteValues
    End If
Else
    'Save Archive
    wbArchive = RelativePath & "Archived\" & wbSource.Name
    wbSource.SaveAs Filename:=wbArchive
End If
'Delete Sourcebook
wbSource.Close False
Kill KillFile
sFile = Dir()
Loop
Set wbSource = Nothing
Application.DisplayAlerts = True
End Sub

 

[tonywatsonhelp]

Thank you GL whiz,
I'll try it now
Tony

 

[EFANYoutube]

Hi Again
This should do the trick

Sub ImportWorksheets()
Application.DisplayAlerts = False
RelativePath = ThisWorkbook.Path & "\"


Dim sFile As String
Dim wbSource As Workbook
Dim wbArchive As String, wbNew As String, KillFile As String
Dim ProductionNumber As Integer
Dim PasteSheet As Worksheet
ProductionNumber = 1
sFile = Dir(RelativePath & "*.csv")
Do Until sFile = ""
Set PasteSheet = ThisWorkbook.Sheets("Production")
Set wbSource = Workbooks.Open(RelativePath & sFile)
KillFile = wbSource.Path & "\" & wbSource.Name

If ActiveSheet.Range("G1") = "isrcs" Then
    LR1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    ActiveSheet.Range("H1") = "ISRC"
    ActiveSheet.Range("H2:H" & LR1).FormulaR1C1 = "=LEFT(RC[-2],2)"

    ActiveSheet.Range("$A$1:$H$" & LR1).AutoFilter Field:=8, Criteria1:="GB"
    ActiveSheet.Range("$A$1:$H$" & LR1).AutoFilter Field:=5, Criteria1:=""

    ActiveSheet.Range("$A$2:$H$" & LR1).SpecialCells(xlCellTypeVisible).Copy

    ThisWorkbook.Activate
    LR2 = PasteSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
NewSheet:
    On Error Resume Next
        PasteSheet.Range("A" & LR2).PasteSpecial xlPasteValues
    If Err <> 0 Then
        Err = 0
        ThisWorkbook.Sheets.Add
        ActiveSheet.Name = "Production " & ProductionNumber
        Set PasteSheet = ThisWorkbook.Sheets("Production " & ProductionNumber)
        ProductionNumber = ProductionNumber + 1
        GoTo NewSheet
    End If
    On Error GoTo 0
Else
    'Save Archive
    wbArchive = RelativePath & "Archived\" & wbSource.Name
    wbSource.SaveAs Filename:=wbArchive

End If

'Delete Sourcebook
wbSource.Close False
Kill KillFile

sFile = Dir()
Loop
Set wbSource = Nothing
Application.DisplayAlerts = True

End Sub

 

[tonywatsonhelp]

Thanks Efan,
I actually had to combine both your ideas to get what i wanted as I was having problems with the new sheet becoming the criteria for if the sheet was big enough,
thanks to both your ideas i managed to get it to do what i wanted perfectly,
thanks
Tony

 

[JLGWhiz]

Glad we could assist,
regards, JLG