Find Next Record and Create a new sheet

P

Pestomania

Active Member
Joined
May 30, 2018
Messages
292
Office Version
  1. 365
Platform
  1. Windows
Hello,

I am trying to find a way to start on cell A1 and select all rows until the value in column A changes. Once Column A changes, it should create a new sheet, copy and paste all rows, rename to the value in cell A1 of the new sheet (removing any trailing spaces).

After it does all of that, I would like excel to go back and create a folder in a specific file location "My Documents" and name the folder "Route Backups" & current date (mm-dd-yyyy). Once the folder is completed, it would cycle through and save all sheets as individual CSV files.
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Let me try to rephrase this:
  1. You have a sheet1 in workbook1 that has loads of entries in Column A.
  2. The macro runs from A1 down, and when the value changes, say in A40, it:
  3. creates a new sheet(sheet2), copies rows 1:39 from sheet1 into sheet2.
  4. This sheet2 gets named after the value in its A1.
  5. Then presumably the macro continues on sheet1. When the value changes again, say row 85, it
  6. creates a new sheet, as per 3 & 4 above.
  7. Once column A on sheet1 has been processed a folder is created in My Docs, named Route Backups & current date
  8. Then oa csv of each of the sheets is created and stored in this folder
 
Upvote 0
Yes. That is a much better description I had. Thank you for that.

I have the csv script, but do not have a replace any illegal characters in the name of the file.
 
Upvote 0
VBA Code: 
Option Explicit

'1. You have a sheet1 in workbook1 that has loads of entries in Column A.
'2. A folder is created in My Docs, named Route Backups & current date
'3. The macro runs from A1 down, and when the value changes, say in A40, it:
'4. copies rows 1:39 from sheet1 into sheet in a temporary workbook.
'5. This sheet gets named after the value in its A1.
'6. This sheet is exported as .csv in this folder
'7. Then the macro continues on sheet1. When the value changes again, say row 85, it
'exports this section as per 4-6 above.

Sub SetupCSV()
    Dim wsSrc As Worksheet, wsOut As Worksheet
    Dim wbCSV As Workbook
    Dim lRsrc As Long, lRLast As Long, lC As Long
    Dim vOut As Variant, vIn As Variant
    Dim sFolderName As String, sTab As String, sRootPath As String
    
    Set wsSrc = Sheets("Sheet1")    '<<<< Modify as required. This is the sheet with all the entries to be sorted
    sRootPath = "R:\Temp"           '<<<< Modify as required. Note: _
                                          This root directory where the backup subdirectories will be stored must exist
    
    'make the name of the subdirectory for today
    sFolderName = "\Route Backups " & Format(Date, "yyyy-mm-dd")
    'create the directory if not exists
    If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
        MkDir sRootPath & sFolderName
            'check if created OK
        If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
            MsgBox prompt:="Someting went wrong trying to create the " & vbCrLf & _
                            "subdirectory " & sFolderName & _
                            " in the root directory " & sRootPath & ". " & vbCrLf & _
                            "Please check if rootpath exists. Then retry.", _
                   Buttons:=vbCritical + vbOKOnly, _
                   Title:="Error creating sub directory"
            Exit Sub
        End If
    End If
    
    Application.ScreenUpdating = False
    Set wbCSV = Workbooks.Add
    Set wsOut = wbCSV.Sheets(1)
    
    'load column A in array for fast reading
    lRsrc = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row + 1
    vIn = wsSrc.Range("A1").Resize(lRsrc, 1)
    
    lC = wsSrc.Range("A1").CurrentRegion.Columns.Count
    lRLast = 1
    
    For lRsrc = 2 To lRsrc
        If vIn(lRsrc, 1) <> vIn(lRsrc - 1, 1) Then
            'change detected. Read the section above into array
            vOut = wsSrc.Cells(lRLast, 1).Resize(lRsrc - lRLast, lC).Value
            lRLast = lRsrc
            'clear sheet and copy
            wsOut.Range("A1").CurrentRegion.Clear
            wsOut.Range("A1").Resize(UBound(vOut, 1), UBound(vOut, 2)).Value = vOut
            wsOut.Name = wsOut.Range("A1")
            
            'create csv
            wsOut.SaveAs Filename:=sRootPath & sFolderName & "\" & wsOut.Name & ".csv", _
                         FileFormat:=xlCSV, _
                         CreateBackup:=False
            
        End If
    Next lRsrc
    
    'close and clean up
    Workbooks(wsOut.Name & ".csv").Close savechanges:=False
    Set wsSrc = Nothing
    Set wsOut = Nothing
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
If you want to check for illegal characters, then use this code instead:

VBA Code: 
Option Explicit

'1. You have a sheet1 in workbook1 that has loads of entries in Column A.
'2. A folder is created in My Docs, named Route Backups & current date
'3. The macro runs from A1 down, and when the value changes, say in A40, it:
'4. copies rows 1:39 from sheet1 into sheet in a temporary workbook.
'5. This sheet gets named after the value in its A1.
'6. This sheet is exported as .csv in this folder
'7. Then the macro continues on sheet1. When the value changes again, say row 85, it
'exports this section as per 4-6 above.

Sub SetupCSV()
    Dim wsSrc As Worksheet, wsOut As Worksheet
    Dim wbCSV As Workbook
    Dim lRsrc As Long, lRLast As Long, lC As Long
    Dim vOut As Variant, vIn As Variant
    Dim sFolderName As String, sTab As String, sRootPath As String
    
    Set wsSrc = Sheets("Sheet1")    '<<<< Modify as required. This is the sheet with all the entries to be sorted
    sRootPath = "R:\Temp"           '<<<< Modify as required. Note: _
                                          This root directory where the backup subdirectories will be stored must exist
    
    'make the name of the subdirectory for today
    sFolderName = "\Route Backups " & Format(Date, "yyyy-mm-dd")
    'create the directory if not exists
    If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
        MkDir sRootPath & sFolderName
            'check if created OK
        If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
            MsgBox prompt:="Someting went wrong trying to create the " & vbCrLf & _
                            "subdirectory " & sFolderName & _
                            " in the root directory " & sRootPath & ". " & vbCrLf & _
                            "Please check if rootpath exists. Then retry.", _
                   Buttons:=vbCritical + vbOKOnly, _
                   Title:="Error creating sub directory"
            Exit Sub
        End If
    End If
    
    Application.ScreenUpdating = False
    Set wbCSV = Workbooks.Add
    Set wsOut = wbCSV.Sheets(1)
    
    'load column A in array for fast reading
    lRsrc = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row + 1
    vIn = wsSrc.Range("A1").Resize(lRsrc, 1)
    
    lC = wsSrc.Range("A1").CurrentRegion.Columns.Count
    lRLast = 1
    
    For lRsrc = 2 To lRsrc
        If vIn(lRsrc, 1) <> vIn(lRsrc - 1, 1) Then
            'change detected. Read the section above into array
            vOut = wsSrc.Cells(lRLast, 1).Resize(lRsrc - lRLast, lC).Value
            lRLast = lRsrc
            'clear sheet and copy
            wsOut.Range("A1").CurrentRegion.Clear
            wsOut.Range("A1").Resize(UBound(vOut, 1), UBound(vOut, 2)).Value = vOut
            wsOut.Name = ReplaceIllegalCharacters(wsOut.Range("A1"), "_")
            
            'create csv
            wsOut.SaveAs Filename:=sRootPath & sFolderName & "\" & wsOut.Name & ".csv", _
                         FileFormat:=xlCSV, _
                         CreateBackup:=False
            
        End If
    Next lRsrc
    
    'close and clean up
    Workbooks(wsOut.Name & ".csv").Close savechanges:=False
    Set wsSrc = Nothing
    Set wsOut = Nothing
    Application.ScreenUpdating = True
    
End Sub


Function ReplaceIllegalCharacters(strIn As String, strChar As String) As String
'courtesy: jainashish
    Dim strSpecialChars As String
    Dim i As Long
    strSpecialChars = "~""#%&*:<>?{|}/\[]" & Chr(10) & Chr(13)

    For i = 1 To Len(strSpecialChars)
        strIn = Replace(strIn, Mid$(strSpecialChars, i, 1), strChar)
    Next

    ReplaceIllegalCharacters = strIn
End Function
 
Upvote 0
This worked amazingly!!! There are many files that have trailing spaces due to how our system spits out data. Is there a way to remove those when doing the illegal characters?
 
Upvote 0
sijpie said:
If you want to check for illegal characters, then use this code instead:

VBA Code: 
Option Explicit

'1. You have a sheet1 in workbook1 that has loads of entries in Column A.
'2. A folder is created in My Docs, named Route Backups & current date
'3. The macro runs from A1 down, and when the value changes, say in A40, it:
'4. copies rows 1:39 from sheet1 into sheet in a temporary workbook.
'5. This sheet gets named after the value in its A1.
'6. This sheet is exported as .csv in this folder
'7. Then the macro continues on sheet1. When the value changes again, say row 85, it
'exports this section as per 4-6 above.

Sub SetupCSV()
    Dim wsSrc As Worksheet, wsOut As Worksheet
    Dim wbCSV As Workbook
    Dim lRsrc As Long, lRLast As Long, lC As Long
    Dim vOut As Variant, vIn As Variant
    Dim sFolderName As String, sTab As String, sRootPath As String
  
    Set wsSrc = Sheets("Sheet1")    '<<<< Modify as required. This is the sheet with all the entries to be sorted
    sRootPath = "R:\Temp"           '<<<< Modify as required. Note: _
                                          This root directory where the backup subdirectories will be stored must exist
  
    'make the name of the subdirectory for today
    sFolderName = "\Route Backups " & Format(Date, "yyyy-mm-dd")
    'create the directory if not exists
    If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
        MkDir sRootPath & sFolderName
            'check if created OK
        If Len(Dir(sRootPath & sFolderName, vbDirectory)) = 0 Then
            MsgBox prompt:="Someting went wrong trying to create the " & vbCrLf & _
                            "subdirectory " & sFolderName & _
                            " in the root directory " & sRootPath & ". " & vbCrLf & _
                            "Please check if rootpath exists. Then retry.", _
                   Buttons:=vbCritical + vbOKOnly, _
                   Title:="Error creating sub directory"
            Exit Sub
        End If
    End If
  
    Application.ScreenUpdating = False
    Set wbCSV = Workbooks.Add
    Set wsOut = wbCSV.Sheets(1)
  
    'load column A in array for fast reading
    lRsrc = wsSrc.Cells(Rows.Count, 1).End(xlUp).Row + 1
    vIn = wsSrc.Range("A1").Resize(lRsrc, 1)
  
    lC = wsSrc.Range("A1").CurrentRegion.Columns.Count
    lRLast = 1
  
    For lRsrc = 2 To lRsrc
        If vIn(lRsrc, 1) <> vIn(lRsrc - 1, 1) Then
            'change detected. Read the section above into array
            vOut = wsSrc.Cells(lRLast, 1).Resize(lRsrc - lRLast, lC).Value
            lRLast = lRsrc
            'clear sheet and copy
            [B]wsOut.Cells.Clear[/B]
            [B]wsOut.Cells.Resize(UBound(vOut, 1), UBound(vOut, 2)).Value = vOut[/B]
            wsOut.Name = ReplaceIllegalCharacters(wsOut.Range("A1"), "_")
          
            'create csv
            wsOut.SaveAs Filename:=sRootPath & sFolderName & "\" & wsOut.Name & ".csv", _
                         FileFormat:=xlCSV, _
                         CreateBackup:=False
          
        End If
    Next lRsrc
  
    'close and clean up
    Workbooks(wsOut.Name & ".csv").Close savechanges:=False
    Set wsSrc = Nothing
    Set wsOut = Nothing
    Application.ScreenUpdating = True
  
End Sub


Function ReplaceIllegalCharacters(strIn As String, strChar As String) As String
'courtesy: jainashish
    Dim strSpecialChars As String
    Dim i As Long
    strSpecialChars = "~""#%&*:<>?{|}/\[]" & Chr(10) & Chr(13)

    For i = 1 To Len(strSpecialChars)
        strIn = Replace(strIn, Mid$(strSpecialChars, i, 1), strChar)
    Next

    ReplaceIllegalCharacters = strIn
End Function
Click to expand...
I did change one thing.

VBA Code: 
wsOut.Cells.Clear[/B]
            [B]wsOut.Cells.Resize(UBound(vOut, 1), UBound(vOut, 2)).Value = vOut[/B]
 
Upvote 0
Replace the last line of the sub ReplaceIllegalCharacters with
VBA Code: 
ReplaceIllegalCharacters = trim(strIn)
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
VBA help required in creating multiple workbooks from one workbook.
Replies
5
Views
267
jolivanes
jolivanes
M
  • Question
Macro - Merge all files into one sheet
Replies
2
Views
191
MountainFog
M
S
  • Solved
For each row, create new folder based on single cell value, then save exported XML doc to matching folder.
Replies
3
Views
139
shand
S
S
  • Question
VBA to loop through sheets and copy to new workbook including the pivot tab
Replies
0
Views
182
simont1975
S
I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
199
Insurance Dave
I

Forum statistics

Threads
1,214,585
Messages
6,120,391
Members
448,957
Latest member
Hat4Life

Share this page

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
Back
Top