View Full Version : Splitting data by range
khaledalaydi
11-14-2018, 08:13 AM
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
11-14-2018, 09:41 AM
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
12-11-2018, 12:52 AM
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
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
12-16-2018, 06:56 PM
Hello mana!
日本の方は珍しいですね、僕は中国の者ですが、よろしくお願いします。
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.