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

tonywatsonhelp

Well-known Member
Joined
Feb 24, 2014
Messages
2,679
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
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

VBA Code:
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
 

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
this is untested, so post back with problems related to the modification in red font.

Rich (BB code):
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
 
Solution

EFANYoutube

Board Regular
Joined
May 19, 2017
Messages
162
Hi Again
This should do the trick

VBA Code:
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

Well-known Member
Joined
Feb 24, 2014
Messages
2,679
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
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

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Glad we could assist,
regards, JLG
 

Watch MrExcel Video

Forum statistics

Threads
1,122,850
Messages
5,598,457
Members
414,239
Latest member
xnanx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top