Select data contained within a symbol and move it to a new sheet

[Panther13]

Hi,

What I'm trying to do is load a CSV file and split in onto multiple sheets based on a symbol

i.e. Column A;Column B; Column C
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data
%% <---- See this and starts a new sheet for the rest of the import
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data
Date; Data; Data

This has to happen more than once so I'm hoping I'll be able to use some type of FindNext loop, but I'm not sure how

Thanks for any help I can get,

Sam

 

[missgari]

Hello Sam,

I'm new here and this is my first reply, so please feel free to make any comments or corrections. I've been learning from all of you so now I feel in debt and I'm going to try to contribute to the common knowledge of the board.

Here's how I would approach your problem:

Sub SplitCSV()

Dim OriginalSheet, CurrentSheet As Worksheet
Dim Counter, I As Long

'Defines the names for the original and variable sheets

Set OriginalSheet = ActiveSheet
Set CurrentSheet = Sheets.Add
CurrentSheet.Name = "2"
Counter = 1

'Loops through all the rows and pastes it in last sheet until it finds that symbol then starts in a new sheet

For I = 1 To OriginalSheet.Range("A1").End(xlDown).Row

    If OriginalSheet.Range("A" & I).Value = "%%" Then
        Set CurrentSheet = Sheets.Add
        CurrentSheet.Name = Sheets.Count
        Counter = 1
    Else
        OriginalSheet.Rows(I).Copy
        CurrentSheet.Range("A" & Counter).EntireRow.PasteSpecial
        Counter = Counter + 1
    End If

Next

End Sub

It works for me, plz let me know if you have any issues as I'm not used to sharing code...

good luck!

Maria

 

[Panther13]

Thanks for your reply Maria!

Unfortunately it came a little late because I already figured it out.

Just FYI this is what I did

Sub Split()

  Dim objDestWkBk As Workbook
  Dim objDestWkSht As Worksheet
  Dim varResult As Variant
  Dim varStartTime As Variant
  Dim varEndTime As Variant
  Dim dblCounter As Double
  Dim lngFNumber As Long
  Dim lngCounter As Long
  Dim i As Long
  Dim strResult As String
  Dim strFName As String
  Dim strDelimiter As String
 
  On Error GoTo CleanUp
  Application.ScreenUpdating = False
 
  'Initialize variables
  strFName = CStr(Application.GetOpenFilename)
  If strFName = "" Or strFName = "False" Then End
  lngFNumber = FreeFile()
  dblCounter = 1
  lngCounter = 1
 
  'Open File
  Open strFName For Input As #lngFNumber
  varStartTime = Time
 
  'Create new workbook
  Set objDestWkBk = Workbooks.Add(Template:=xlWorksheet)
  Set objDestWkSht = objDestWkBk.Worksheets(1)
 
    'Import the File
    Do While Seek(lngFNumber) <= LOF(lngFNumber)
    Do While Not EOF(1)
        Application.StatusBar = "Importing Row " & _
            Format(dblCounter, "#,###") & ": " & _
            Format(Seek(lngFNumber), "#,###") & " / " & _
            Format(LOF(lngFNumber), "#,###") & " bytes"
        Line Input #lngFNumber, strResult
    Dim TextLine As String
        'Check if new sheet is required
        If Left(strResult, 2) = "%%" Then
            'Reset lngCounter for new sheet
            lngCounter = 1
                With objDestWkBk
                    Set objDestWkSht = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
                End With
        Else
            If Left(strResult, 1) = "=" Then _
                    strResult = "'" & strResult
                    varResult = Split(strResult, strDelimiter, -1, vbTextCompare)
 
                For i = LBound(varResult) To UBound(varResult)
                    objDestWkSht.Cells(lngCounter, i + 1).Value = varResult(i)
                Next i
            'Increment lngcounter
            lngCounter = lngCounter + 1
        End If
        'Increment dblcounter
        dblCounter = dblCounter + 1
    Loop
    Loop

'Run the text-to-columns wizard on both sheets.
    For i = 1 To objDestWkBk.Sheets.Count
            Sheets(i).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                          TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                          Semicolon:=True, Comma:=True, Space:=False, Other:=False, FieldInfo _
                          :=Array(Array(1, 1), Array(2, 1), Array(3, 1))
            Sheets(i).Select
            Cells.EntireColumn.AutoFit
            Range("A1").Select
    Next i
    
z = Sheets.Count
For x = 1 To z
A = Sheets(x).Range("A1").Value
Sheets(x).Name = Left(A, 25)
Next
 
Dim CurrentSheet As Object
' Loop through all selected sheets.
    For Each CurrentSheet In Application.ActiveWorkbook.Sheets
    ' Delete top row of each sheet.
    CurrentSheet.Range("a1").EntireRow.Delete
    Next CurrentSheet


CleanUp:
  Close
  Application.StatusBar = False
  Application.ScreenUpdating = True
        If Err.Number <> 0 Then MsgBox "Error " & Err.Number & ": " & Err.Description
End Sub