Copy range from string until reach another string

[lmcquade91]

Hi guys!

I am fairly new to coding and have been playing around, so am self taught.

I am having some trouble with the below.

I have a CSV file containing 14 days of roster data. I want to copy each day's data onto a new sheet.

I was thinking of using cells.find to look for the string "loc" as that separates each days data, but am not sure how to copy FROM that string UNTIL reaching next one.

if anyone can give me some code or help me out it would be greatly appreciated!! Thank you guys!

 

[Anthony47]

Your csv file is already open in Excel, correct?
Which is the layout of the data? An image should be sufficient

 

[HighAndWilder]

Hi guys!

I am fairly new to coding and have been playing around, so am self taught.

I am having some trouble with the below.

I have a CSV file containing 14 days of roster data. I want to copy each day's data onto a new sheet.

I was thinking of using cells.find to look for the string "loc" as that separates each days data, but am not sure how to copy FROM that string UNTIL reaching next one.

if anyone can give me some code or help me out it would be greatly appreciated!! Thank you guys!

Welcome to Mr Excel

This code may help you. You may be able to use some of the code for other projects.

I have made a number of assumptions:

1. That the CSV file has a header row.
2. That the date is in column 1.
3. That the worksheets created are to be named with this convention: DD MMM YYY - 01 Aug 2024

Let me know if any of these are not the case.

Run the subImportCSVFileAndSplit procedure.

Public Sub subImportCSVFileAndSplit()
Dim arrUnique() As Variant
Dim arrData() As Variant
Dim Wb As Workbook
Dim WsData As Worksheet
Dim i As Integer
Dim strFormula As String
Dim WsExtract As Worksheet

On Error GoTo Err_Handler

  ActiveWorkbook.Save
     
  ' Import the data from the CSV file and populate the Data worksheet.
  Set WsData = fncGetDataFromFile(ActiveWorkbook, "CSV-" & Format(Now(), "DDMMYYYYHHMMSS"))

  If WsData Is Nothing Then
    MsgBox "No data has been imported.", vbOKOnly, "Warning!"
    Exit Sub
  End If
  
  Set Wb = ThisWorkbook
  
  ' Specify the data range with which to work on.
  With WsData.[a1].CurrentRegion.Offset(1)
  
    With .Resize(.Rows.Count, .Columns.Count)
      
      ' Put a list of the dates into the arrUnique array.
      ' Sort into date order ascending.
      arrUnique = Evaluate("SORT(UNIQUE('" & WsData.Name & "'!" & .Columns(1).Address & "))")
      
      ' Loop through all of the dates.
      For i = LBound(arrUnique) To UBound(arrUnique) - 1
                           
        ' Create a sheet into which to put the data for each date.
        Set WsExtract = fncCreateSheet(Wb, Format(arrUnique(i, 1), "DD MMM YYYY"))
     
        ' Compile a formula to identify the rows to extract.
        strFormula = "VSTACK('" & WsData.Name & "'!" & .Rows(1).Offset(-1).Address & ",FILTER('" & WsData.Name & "'!" & _
         .Address & ",'" & WsData.Name & "'!" & .Columns(1).Address & " = " & arrUnique(i, 1) & "))"
  
        ' Evaluate the formula and put the data to extract into the arrData array.
        arrData = Evaluate(strFormula)
   
        ' Write the data from the array to the new sheet created and apply a format
        ' to the date column.
        With WsExtract.Cells(1, 1)
          .Resize(UBound(arrData), UBound(arrData, 2)) = arrData
          .EntireColumn.NumberFormat = "DD/MM/YYYY"
        End With
       
       Next i
      
    End With
    
  End With
   
  ActiveWorkbook.Save
  
  Worksheets(Format(arrUnique(1, 1), "DD MMM YYYY")).Activate
  
  MsgBox "CSV Data Imported and Split into " & i - 1 & " sheets.", vbOKOnly, "Confirmation"

Exit_Handler:

  Exit Sub

Err_Handler:

  MsgBox "There has been any error." & vbCrLf & Err.Number & " " & Err.Description, vbOKCancel, "Warning"

End Sub

' Function to create a new woksheet and return a worksheet object.
' Deletes worksheet by the same name if it already exists.
Private Function fncCreateSheet(Wb As Workbook, strWorksheet As String) As Worksheet

  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  
  Wb.Sheets.Add After:=Wb.Sheets(Wb.Sheets.Count)

  ActiveSheet.Name = strWorksheet
  
  Set fncCreateSheet = ActiveSheet

End Function

' Function to get data from a CSV and populate a worksheet as specifed
' by the workbook object and worksheet name passed as parameters.
Public Function fncGetDataFromFile(Wb As Workbook, strWorksheet As String) As Worksheet
Dim strFileToOpen As Variant
Dim WbOpenBook As Workbook
Dim Ws As Worksheet

  strFileToOpen = Application.GetOpenFilename(Title:="Browse for your CSV File.", FileFilter:="CSV Files (*.csv*),*csv*")
  
  If strFileToOpen <> False Then
    Set Ws = fncCreateSheet(Wb, strWorksheet)
    Set WbOpenBook = Application.Workbooks.Open(strFileToOpen)
    WbOpenBook.Sheets(1).Range("A1").CurrentRegion.Copy
    Ws.Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    WbOpenBook.Close False
    Ws.Range("A1").Select
    Set fncGetDataFromFile = Ws
  End If
  
End Function

 

[lmcquade91]

Wow thank you so much for your input

Your csv file is already open in Excel, correct?
Which is the layout of the data? An image should be sufficient

 

[lmcquade91]

Welcome to Mr Excel

This code may help you. You may be able to use some of the code for other projects.

I have made a number of assumptions:

1. That the CSV file has a header row.
2. That the date is in column 1.
3. That the worksheets created are to be named with this convention: DD MMM YYY - 01 Aug 2024

Let me know if any of these are not the case.

Run the subImportCSVFileAndSplit procedure.

Public Sub subImportCSVFileAndSplit()
Dim arrUnique() As Variant
Dim arrData() As Variant
Dim Wb As Workbook
Dim WsData As Worksheet
Dim i As Integer
Dim strFormula As String
Dim WsExtract As Worksheet

On Error GoTo Err_Handler

  ActiveWorkbook.Save
    
  ' Import the data from the CSV file and populate the Data worksheet.
  Set WsData = fncGetDataFromFile(ActiveWorkbook, "CSV-" & Format(Now(), "DDMMYYYYHHMMSS"))

  If WsData Is Nothing Then
    MsgBox "No data has been imported.", vbOKOnly, "Warning!"
    Exit Sub
  End If
 
  Set Wb = ThisWorkbook
 
  ' Specify the data range with which to work on.
  With WsData.[a1].CurrentRegion.Offset(1)
 
    With .Resize(.Rows.Count, .Columns.Count)
     
      ' Put a list of the dates into the arrUnique array.
      ' Sort into date order ascending.
      arrUnique = Evaluate("SORT(UNIQUE('" & WsData.Name & "'!" & .Columns(1).Address & "))")
     
      ' Loop through all of the dates.
      For i = LBound(arrUnique) To UBound(arrUnique) - 1
                          
        ' Create a sheet into which to put the data for each date.
        Set WsExtract = fncCreateSheet(Wb, Format(arrUnique(i, 1), "DD MMM YYYY"))
    
        ' Compile a formula to identify the rows to extract.
        strFormula = "VSTACK('" & WsData.Name & "'!" & .Rows(1).Offset(-1).Address & ",FILTER('" & WsData.Name & "'!" & _
         .Address & ",'" & WsData.Name & "'!" & .Columns(1).Address & " = " & arrUnique(i, 1) & "))"
 
        ' Evaluate the formula and put the data to extract into the arrData array.
        arrData = Evaluate(strFormula)
  
        ' Write the data from the array to the new sheet created and apply a format
        ' to the date column.
        With WsExtract.Cells(1, 1)
          .Resize(UBound(arrData), UBound(arrData, 2)) = arrData
          .EntireColumn.NumberFormat = "DD/MM/YYYY"
        End With
      
       Next i
     
    End With
   
  End With
  
  ActiveWorkbook.Save
 
  Worksheets(Format(arrUnique(1, 1), "DD MMM YYYY")).Activate
 
  MsgBox "CSV Data Imported and Split into " & i - 1 & " sheets.", vbOKOnly, "Confirmation"

Exit_Handler:

  Exit Sub

Err_Handler:

  MsgBox "There has been any error." & vbCrLf & Err.Number & " " & Err.Description, vbOKCancel, "Warning"

End Sub

' Function to create a new woksheet and return a worksheet object.
' Deletes worksheet by the same name if it already exists.
Private Function fncCreateSheet(Wb As Workbook, strWorksheet As String) As Worksheet

  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
 
  Wb.Sheets.Add After:=Wb.Sheets(Wb.Sheets.Count)

  ActiveSheet.Name = strWorksheet
 
  Set fncCreateSheet = ActiveSheet

End Function

' Function to get data from a CSV and populate a worksheet as specifed
' by the workbook object and worksheet name passed as parameters.
Public Function fncGetDataFromFile(Wb As Workbook, strWorksheet As String) As Worksheet
Dim strFileToOpen As Variant
Dim WbOpenBook As Workbook
Dim Ws As Worksheet

  strFileToOpen = Application.GetOpenFilename(Title:="Browse for your CSV File.", FileFilter:="CSV Files (*.csv*),*csv*")
 
  If strFileToOpen <> False Then
    Set Ws = fncCreateSheet(Wb, strWorksheet)
    Set WbOpenBook = Application.Workbooks.Open(strFileToOpen)
    WbOpenBook.Sheets(1).Range("A1").CurrentRegion.Copy
    Ws.Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    WbOpenBook.Close False
    Ws.Range("A1").Select
    Set fncGetDataFromFile = Ws
  End If
 
End Function

Hi High&Wilder,

Thank you so much for taking the time to reply to me and so sorry for my delayed response, I thought my photo had uploaded but actually it did not. I have now attached so you can get a closer look

To answer your assumptions:

1. That the CSV file has a header row. Yes but it is not right at the top
2. That the date is in column 1. No, only noted in Row E at the top of each section
3. That the worksheets created are to be named with this convention: DD MMM YYY - 01 Aug 2024. Can name however, but as long as it matches the date, even without the year is okay

Looking forward to hearing back from you! I've had many sleepless nights trying to work this out!

Lara

 

[lmcquade91]

Wow thank you so much for your input

**Sorry I hit send before I had finished typing.

I wanted to say Thank you for viewing my CSV and any help would be appreciated

 

[HighAndWilder]

**Sorry I hit send before I had finished typing.

I wanted to say Thank you for viewing my CSV and any help would be appreciated

Hi Lara

I hope that you will be able to sleep now after using this code.

The file/s that have is not really what is considered to be a CSV file.

A CSV is normally just a text file with data on each line, each different data item separated by a comma, another character or a tab.
See image for a simple example.

This code will hopefully work but the layout of your file is crucial to this working. If it changes the code may not work as intended.

Paste the code into a Main Code Module and run the subImportAndSplitData procedure.

You will be prompted to select the file to import.

Private Sub subImportAndSplitData()
Dim WsData As Worksheet
Dim intRow As Integer
Dim arrDate() As String
Dim Ws As Worksheet
Dim rngData As Range
Dim intSheet As Integer
Dim strFirst As String
On Error GoTo Err_Handler

  With ActiveWorkbook
    .Save
  End With

  Set WsData = fncGetWorksheetFromFile(ActiveWorkbook, "Structured")
  
  If WsData Is Nothing Then
    MsgBox "No data has been imported.", vbOKOnly, "Warning!"
    Exit Sub
  End If
  
  intRow = WsData.Cells.SpecialCells(xlLastCell).Row
    
  With WsData
  
    Do Until intRow = 2
      
      If Not IsEmpty(.Range("A" & intRow)) Then
      
        intSheet = intSheet + 1
        
        Set rngData = .Range("A" & intRow).CurrentRegion
            
        arrDate = Split(rngData.Cells(1, 5).Offset(-4, 0).Value, " ")
                
        Set Ws = fncCreateSheet(ActiveWorkbook, arrDate(1) & " " & arrDate(2))
        If strFirst = "" Then
          strFirst = arrDate(1) & " " & arrDate(2)
        End If
        
        With .Range("A" & intRow).CurrentRegion
          .Cells(1, 1).Interior.Color = vbBlue
          Ws.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
          Ws.Cells.EntireColumn.AutoFit
        End With
        
        intRow = rngData.Cells(1).Row - 1
   
      Else
    
        intRow = intRow - 1

      End If

    Loop

  End With
  
  With ActiveWorkbook
    .Save
    .Sheets(strFirst).Activate
  End With
  
  MsgBox "Data has been imported and " & intSheet & " sheets have been created.", vbOKOnly, "Confirmation"

Exit_Handler:

  Exit Sub

Err_Handler:

  MsgBox "There has been any error." & vbCrLf & Err.Number & " " & Err.Description, vbOKCancel, "Warning"

End Sub

Private Sub subDeleteWorksheet(Wb As Workbook, strWorksheet As String)

  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True

End Sub

Private Function fncGetWorksheetFromFile(Wb As Workbook, strWorksheet As String) As Worksheet
Dim strFileToOpen As Variant
Dim WbOpenBook As Workbook
Dim Ws As Worksheet
Dim WbActive As Workbook

  Set WbActive = ActiveWorkbook
  
  Call subDeleteWorksheet(Wb, strWorksheet)
 
  strFileToOpen = Application.GetOpenFilename(Title:="Browse for your Excel file.", FileFilter:="Microsoft Excel Files (*.xlsx; *.xls), (*.xlsx; *.xls), All Files, *.*")
    
  If strFileToOpen <> False Then
    Set WbOpenBook = Application.Workbooks.Open(strFileToOpen)
    With WbOpenBook
      .Sheets(1).Copy after:=WbActive.Sheets(Sheets.Count)
      .Close False
    End With
    ActiveSheet.Name = strWorksheet
    Set fncGetWorksheetFromFile = ActiveSheet
  Else
    Exit Function
  End If
    
End Function

Private Function fncCreateSheet(Wb As Workbook, strWorksheet As String) As Worksheet

  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  
  Wb.Sheets.Add after:=Wb.Sheets(Wb.Sheets.Count)

  ActiveSheet.Name = strWorksheet
  
  Set fncCreateSheet = ActiveSheet

End Function

 

[lmcquade91]

Hi Lara

I hope that you will be able to sleep now after using this code.

The file/s that have is not really what is considered to be a CSV file.

A CSV is normally just a text file with data on each line, each different data item separated by a comma, another character or a tab.
See image for a simple example.

This code will hopefully work but the layout of your file is crucial to this working. If it changes the code may not work as intended.

Paste the code into a Main Code Module and run the subImportAndSplitData procedure.

You will be prompted to select the file to import.

Private Sub subImportAndSplitData()
Dim WsData As Worksheet
Dim intRow As Integer
Dim arrDate() As String
Dim Ws As Worksheet
Dim rngData As Range
Dim intSheet As Integer
Dim strFirst As String
On Error GoTo Err_Handler

  With ActiveWorkbook
    .Save
  End With

  Set WsData = fncGetWorksheetFromFile(ActiveWorkbook, "Structured")
 
  If WsData Is Nothing Then
    MsgBox "No data has been imported.", vbOKOnly, "Warning!"
    Exit Sub
  End If
 
  intRow = WsData.Cells.SpecialCells(xlLastCell).Row
   
  With WsData
 
    Do Until intRow = 2
     
      If Not IsEmpty(.Range("A" & intRow)) Then
     
        intSheet = intSheet + 1
       
        Set rngData = .Range("A" & intRow).CurrentRegion
           
        arrDate = Split(rngData.Cells(1, 5).Offset(-4, 0).Value, " ")
               
        Set Ws = fncCreateSheet(ActiveWorkbook, arrDate(1) & " " & arrDate(2))
        If strFirst = "" Then
          strFirst = arrDate(1) & " " & arrDate(2)
        End If
       
        With .Range("A" & intRow).CurrentRegion
          .Cells(1, 1).Interior.Color = vbBlue
          Ws.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
          Ws.Cells.EntireColumn.AutoFit
        End With
       
        intRow = rngData.Cells(1).Row - 1
  
      Else
   
        intRow = intRow - 1

      End If

    Loop

  End With
 
  With ActiveWorkbook
    .Save
    .Sheets(strFirst).Activate
  End With
 
  MsgBox "Data has been imported and " & intSheet & " sheets have been created.", vbOKOnly, "Confirmation"

Exit_Handler:

  Exit Sub

Err_Handler:

  MsgBox "There has been any error." & vbCrLf & Err.Number & " " & Err.Description, vbOKCancel, "Warning"

End Sub

Private Sub subDeleteWorksheet(Wb As Workbook, strWorksheet As String)

  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True

End Sub

Private Function fncGetWorksheetFromFile(Wb As Workbook, strWorksheet As String) As Worksheet
Dim strFileToOpen As Variant
Dim WbOpenBook As Workbook
Dim Ws As Worksheet
Dim WbActive As Workbook

  Set WbActive = ActiveWorkbook
 
  Call subDeleteWorksheet(Wb, strWorksheet)
 
  strFileToOpen = Application.GetOpenFilename(Title:="Browse for your Excel file.", FileFilter:="Microsoft Excel Files (*.xlsx; *.xls), (*.xlsx; *.xls), All Files, *.*")
   
  If strFileToOpen <> False Then
    Set WbOpenBook = Application.Workbooks.Open(strFileToOpen)
    With WbOpenBook
      .Sheets(1).Copy after:=WbActive.Sheets(Sheets.Count)
      .Close False
    End With
    ActiveSheet.Name = strWorksheet
    Set fncGetWorksheetFromFile = ActiveSheet
  Else
    Exit Function
  End If
   
End Function

Private Function fncCreateSheet(Wb As Workbook, strWorksheet As String) As Worksheet

  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
 
  Wb.Sheets.Add after:=Wb.Sheets(Wb.Sheets.Count)

  ActiveSheet.Name = strWorksheet
 
  Set fncCreateSheet = ActiveSheet

End Function

Wow I am in awe of your amazing code, I will study it until I become a wizard like you!! It worked perfectly

I know this is a bit cheeky but do you think you could just amend slightly the code to work for the attached format as the one I previously sent is actually missing one column, 'location', and I had moved the columns around. This one is the raw one that comes straight from Virtual Roster as an excel doc!

If you don't have time i totally understand and appreciate all the help you have given me so far

Have a wonderful day!

THANK YOU!!!

Lara x

 

[HighAndWilder]

Wow I am in awe of your amazing code, I will study it until I become a wizard like you!! It worked perfectly

I know this is a bit cheeky but do you think you could just amend slightly the code to work for the attached format as the one I previously sent is actually missing one column, 'location', and I had moved the columns around. This one is the raw one that comes straight from Virtual Roster as an excel doc!

If you don't have time i totally understand and appreciate all the help you have given me so far

Have a wonderful day!

THANK YOU!!!

Lara x

Not cheeky at all.

I have plenty of time today but I need a shower and some breakfast first. Be back later.

 

[HighAndWilder]

Wow I am in awe of your amazing code, I will study it until I become a wizard like you!! It worked perfectly

I know this is a bit cheeky but do you think you could just amend slightly the code to work for the attached format as the one I previously sent is actually missing one column, 'location', and I had moved the columns around. This one is the raw one that comes straight from Virtual Roster as an excel doc!

If you don't have time i totally understand and appreciate all the help you have given me so far

Have a wonderful day!

THANK YOU!!!

Lara x

Hi Lara

Delete the previous code and use this code.

Do you do this one source sheet at a time?

Would it be handy to have a means to select the workbook to import the source data sheet from?

I have used the name of 'Structured' for the source data sheet.
If it is any different then just change this line.
Set WsData = Worksheets("Structured")

Run the subImportAndSplitData procedure.

Private Sub subImportAndSplitData()
Dim rngFound As Range
Dim rng As Range
Dim r As Range
Dim arr() As String
Dim Ws As Worksheet
Dim WsData As Worksheet
Dim i As Integer

  ActiveWorkbook.Save
  
  Set WsData = Worksheets("Structured")
  
  WsData.Activate

  Set rngFound = fncFindValueInRange(WsData.UsedRange.Columns(1), "Loc")
    
  If Not rngFound Is Nothing Then
    For Each rng In rngFound.Cells
      arr = Split(rng.Offset(-4, 0).Value, " ")
      Set Ws = fncCreateSheet(ActiveWorkbook, arr(1) & " " & arr(2))
      rng.CurrentRegion.Copy Destination:=Ws.Range("A1")
      i = i + 1
    Next rng
  End If
  
  MsgBox "Data has been processed and " & i & " sheets have been created.", vbOKOnly, "Confirmation"
  
End Sub

Private Function fncFindValueInRange(rngToLookIn As Range, strLookFor As String) As Range
Dim rng As Range
Dim intFirst As Integer
Dim rngUnion As Range

    With rngToLookIn
        
      Set rng = .Find(strLookFor, LookIn:=xlValues, Lookat:=xlWhole)
      
      If Not rng Is Nothing Then
      
        intFirst = rng.Row
          
        If Not rngUnion Is Nothing Then
          Set rngUnion = Union(rngUnion, rng)
        Else
          Set rngUnion = rng
        End If
        
        Do
        
          Set rng = .FindNext(rng)
          If Not rng Is Nothing Then
            If rng.Row <= intFirst Then
              Exit Do
            Else
              Set rngUnion = Union(rngUnion, rng)
            End If
          End If
          
        Loop While Not rng Is Nothing
        
      End If
      
    End With
    
    If Not rngUnion Is Nothing Then
      Set fncFindValueInRange = rngUnion
    End If
    
End Function

Private Function fncCreateSheet(Wb As Workbook, strWorksheet As String) As Worksheet

  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets(strWorksheet).Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  
  Wb.Sheets.Add after:=Wb.Sheets(Wb.Sheets.Count)

  ActiveSheet.Name = strWorksheet
  
  Set fncCreateSheet = ActiveSheet

End Function