Conditional sorting columns based on time

Showhoff

New Member
Joined
Mar 1, 2020
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Hi, I've worked all weekend to learn VBA. I came close, but code is probably what a proper coder would call (very) ugly. I would really appreciate tips on how to make a more streamlined code in addition to the key question:
A rather big set of data are collected on sheet 1 ("Disorderly"). Column A, C, E and so forth are timestamps of when the the measurement is done. Column B, D, F and so forth are the corresponding value of the measurement to the timestamp. I want to make a time-series analysis using the variables, hence it is important that the variables origin from the same time of measure. Some sensor have a malfunction a might skip a measurement or two. The code should collect the sensor vales which belongs to the same timestamp onto the same row in the next sheet ("Organized"). It get's a bit more complicated because there are two kinds of sensors, so it would be beneficial if the time value the code is searching for is a timestamp is within an interval (let's say 45 sec).

Any help will be much appreciated
, hopefully I will learn enough VBA to help other too eventually (gotta start somewhere though).

Here's my filthy code (it was a test, so not every row is included because it takes rather long time to compile all the rows. Also this is without any kind of checking if the "what" part of the range.find function is within a time interval based on the cell which is the one we search for. The code does what it should, but there is a long way to go still. I am going to include code which ensures deleting of rows with empty cell and the empty columns in the "Organized" sheet ):
VBA Code:
Private Sub CommandButton1_Click()

Dim rH As Long, Row As Long, Col As Long, CurrentRow As Long, NextCellValue As Double
Dim RowSize As Integer, ColSize As Integer
Dim foundRng As Range
Set DataArk = Worksheets("Disorderly")
Set ResArk = Worksheets("Organized")
'Copy the first two rows
rH = 1
    For Row = 1 To 9
        ResArk.Rows(Row).EntireRow.Value = DataArk.Rows(rH).EntireRow.Value
        rH = rH + 1
    Next Row
'Copy column 1 and 2 in DataArk
    DataArk.Columns(1).Copy Destination:=ResArk.Columns(1)
    DataArk.Columns(2).Copy Destination:=ResArk.Columns(2)
'Search through every second column for the associated timestamp in column 1
ColSize = DataArk.Cells(3, Columns.Count).End(xlToLeft).Column
  For Row = 10 To 20
    For Col = 3 To ColSize Step 2
            RowSize = DataArk.Cells(Rows.Count, Col).End(xlUp).Row
            Set foundRng = Range(DataArk.Cells(10, Col), DataArk.Cells(RowSize, Col)).Find(DataArk.Cells(Row, 1)) ', After:=DataArk.Cells(CurrentRow - 1, Col), SearchOrder:=xlByRows, SearchDirection:=xlNext)
            If foundRng Is Nothing Then
            ResArk.Activate
            ResArk.Cells(Row, Col + 1) = ""
            DataArk.Activate
            Else
            NextCellValue = DataArk.Cells(foundRng.Row, foundRng.Column + 1).Value
            ResArk.Activate
            ResArk.Cells(Row, Col + 1).Value = NextCellValue
            DataArk.Activate
            End If
   Next Col
Next Row

End Sub
 
Last edited by a moderator:
Current code:
VBA Code:
Private Sub CommandButton1_Click()

Dim rH As Long, Row As Long, Col As Long, NextCellValue As Double
Dim Rowsize As Integer, ColSize As Integer
Dim foundRng As Range
Set DataArk = Worksheets("Disorderly")
Set ResArk = Worksheets("Organized")
'Copy the first two rows
rH = 1
Application.ScreenUpdating = False

    For Row = 1 To 9
        ResArk.Rows(Row).EntireRow.Value = DataArk.Rows(rH).EntireRow.Value
        rH = rH + 1
    Next Row
'Copy column 1 and 2 in DataArk
    DataArk.Columns(1).Copy Destination:=ResArk.Columns(1)
    DataArk.Columns(2).Copy Destination:=ResArk.Columns(2)
'Search through every second column for the associated timestamp in column 1
ColSize = DataArk.Cells(3, Columns.Count).End(xlToLeft).Column
  For Row = 10 To 370
    For Col = 3 To ColSize Step 2
            Rowsize = DataArk.Cells(Rows.Count, Col).End(xlUp).Row
            Set foundRng = Range(DataArk.Cells(3, Col), DataArk.Cells(Rowsize, Col)).Find(DataArk.Cells(Row, 1))
            If foundRng Is Nothing Then
            ResArk.Activate
            ResArk.Cells(Row, Col + 1) = ""
            DataArk.Activate
            Else
            NextCellValue = DataArk.Cells(foundRng.Row, foundRng.Column + 1).Value
            ResArk.Activate
            ResArk.Cells(Row, Col + 1).Value = NextCellValue
            DataArk.Activate
            End If
   Next Col
Next Row

'Call DeletingColumns

Application.ScreenUpdating = True

End Sub
What's missing is:
1) A better execution, this takes a while to compile.
2) Search for time interval in the range.find function
 
Upvote 0

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
What's missing is:
1) A better execution, this takes a while to compile.
Let's try to address that for a start. This is written for a 'Disorderly' sheet having data in columns A:F and 'Organized' being blank (at least from row 2).
That is, I'm trying to replicate sample data in post #7 assuming that is from A2:F4

I suggest that you try it on that small sample data first before trying to modify if your sheets are laid out differently.

VBA Code:
Sub Order_Rows()
  Dim wsD As Worksheet, wsO As Worksheet
  Dim SL As Object, d As Object
  Dim a As Variant, b As Variant, bits As Variant, rc As Variant
  Dim i As Long, j As Long, uba2 As Long, lr As Long
  
  Set SL = CreateObject("System.Collections.Sortedlist")
  Set d = CreateObject("Scripting.Dictionary")
  Set wsD = Sheets("Disorderly")
  Set wsO = Sheets("Organized")
  lr = wsD.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  a = wsD.Range("A2:F" & lr).Value
  uba2 = UBound(a, 2)
  ReDim b(1 To UBound(a, 1) * uba2 / 2, 1 To uba2)
  For i = 1 To UBound(a)
    For j = 1 To uba2 Step 2
      If Len(a(i, j)) > 0 Then
        SL(a(i, j)) = Empty
        d(a(i, j)) = d(a(i, j)) & " " & i & "|" & j
      End If
    Next j
  Next i
  For i = 1 To SL.Count
    bits = Split(Mid(d(SL.GetKey(i - 1)), 2))
    For j = 0 To UBound(bits)
      rc = Split(bits(j), "|")
      b(i, rc(1)) = a(rc(0), rc(1))
      b(i, rc(1) + 1) = a(rc(0), rc(1) + 1)
    Next j
  Next i
  wsO.Range("A2").Resize(SL.Count, uba2).Value = b
End Sub

For me:

Showhoff 2020-03-02 1.xlsm
ABCDEF
1
225.07.2019 01:23:00266.925.07.2019 01:23:00531.125.07.2019 01:23:00488.1
325.07.2019 01:27:0026625.07.2019 01:26:00531.625.07.2019 01:26:00486.4
425.07.2019 01:30:00266.325.07.2019 01:27:00530.325.07.2019 01:27:00486.6
5
Disorderly



Result:

Showhoff 2020-03-02 1.xlsm
ABCDEF
1
225.07.2019 01:23:00266.925.07.2019 01:23:00531.125.07.2019 01:23:00488.1
325.07.2019 01:26:00531.625.07.2019 01:26:00486.4
425.07.2019 01:27:0026625.07.2019 01:27:00530.325.07.2019 01:27:00486.6
525.07.2019 01:30:00266.3
6
Organized
 
Upvote 0

Forum statistics

Threads
1,223,900
Messages
6,175,276
Members
452,629
Latest member
SahilPolekar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top