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!
日本の方は珍しいですね、僕は中国の者ですが、よろしくお願いします。