Splitting data by range

[khaledalaydi]

Hello guys,

I am new here and thought of giving this a try.
I have and will be having excel of many data read from transducers where the first column is date and the second is the read value.
What I am trying to do is to have a macro that will divide my data into sheets depending on inserted ranges of dates.

I am attaching an example of the data. Have anyone done something similar to that? I found online about picking data but nothing about sorting after a range.

Will be glad if anyone could have some hints.

Cheers.

Khaled

[Paul_Hossler]

One way

Option Explicit
Sub SplitDates()
    Dim rData As Range, rNext As Range
    Dim sThis10 As String
    Dim i As Long, x As Long, numRows As Long
    Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
    numRows = ActiveSheet.Rows.Count
    
    Application.ScreenUpdating = False
    
    With rData
        For i = 2 To .Rows.Count
            If .Cells(i, 1).Value = "Time Stamp" Then GoTo GetNextRow
            
            
            Application.StatusBar = "Row " & i
            sThis10 = Left(.Cells(i, 1).Value, 10)
            
            'see if ws exists
            x = 0
            On Error Resume Next
            x = Worksheets(sThis10).Index
            On Error GoTo 0
            
            'new WS, not exists so make one
            If x = 0 Then
                DoEvents
                ThisWorkbook.Worksheets.Add
                ActiveSheet.Name = sThis10
                rData.Rows(1).Copy Worksheets(sThis10).Rows(1)
            End If
                
            'get row below last used row
            Set rNext = Worksheets(sThis10).Cells(numRows, 1).End(xlUp).Offset(1, 0)
            If .Cells(i, 1).Value <> "Time Stamp" Then .Rows(i).Copy rNext
GetNextRow:
        Next i
    End With
    Application.ScreenUpdating = True
    Application.StatusBar = False

End Sub

[大灰狼1976]

Hi khaledalaydi, Another faster way like this.

Private Sub test()
Dim arr, i&, d As Object, sdate$, c&, ky, sht As Worksheet
Set d = CreateObject("scripting.dictionary")
arr = Sheets("09-05").[a1].CurrentRegion
c = UBound(arr, 2)
For i = 2 To UBound(arr)
  If arr(i, 1) <> "Time Stamp" Then
    sdate = Split(arr(i, 1), " ")(0)
    If Not d.exists(sdate) Then
      Set d(sdate) = Cells(i, 1).Resize(, c)
    Else
      Set d(sdate) = Union(d(sdate), Cells(i, 1).Resize(, c))
    End If
  End If
Next i
Application.ScreenUpdating = False
On Error Resume Next
For Each ky In d.keys
  Set sht = Sheets(ky)
  If sht Is Nothing Then
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = ky
    sht.[a1].Resize(, c) = Application.Index(arr, 1)
  End If
  r = sht.[a65536].End(3).Row + 1
  d(ky).Copy sht.Cells(r, 1)
  Set sht = Nothing
Next
Application.ScreenUpdating = True
End Sub

[mana]

AdvancedFilter

Option Explicit


Sub test()
    Dim dic As Object
    Dim rr As Range, r As Range, c As Range
    Dim t As String, ws As Worksheet
    
    Application.ScreenUpdating = False
    
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If ws.Name <> "09-05" Then ws.Delete
    Next
    Application.DisplayAlerts = True
              
    Set dic = CreateObject("scripting.dictionary")
    
    Set rr = Cells(1).CurrentRegion
    Set c = Cells(4).Resize(2)
    c(1).Value = Cells(1).Value
    
    For Each r In rr.Columns(1).Cells
        If r.Value <> "Time Stamp" Then
            t = Split(r.Value, " ")(0)
            If Not dic.exists(t) Then
                dic(t) = Empty
                Set ws = Worksheets.Add
                ws.Name = t
                c(2).Value = t & " *"
                rr.AdvancedFilter xlFilterCopy, c, ws.Cells(1)
            End If
        End If
    Next
    
    c.ClearContents


End Sub

[大灰狼1976]

Hello mana!
日本の方は珍しいですね、僕は中国の者ですが、よろしくお願いします。