Filling in data from source

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
93
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I'm not quite sure what to call the following type of data manipulation so I don't quite know how to phrase my question.

Below is an example of my source data

123412/12/2021 06:30chicken
444412/12/2021 06:30lamp
32112/12/2021 06:30oak
123412/12/2021 07:30blimp attack
123413/12/2021 08:30extended warranty
….….….


A:A contains part IDs (which may/will repeat). B:B contains a date and time (will always be a 15 minute chunk e.g. 06:30,06:45,07:00) associated with a sale period for the ID in A (so 6:30 may appear a few times for different IDs - but IDs will *never* appear more than once for the same time period) this column has been sorted so the earliest date/time will always be first. C:C contains data associated with the ID and Time in A and B

Below is how I wish the data to be presented - A has been transposed and filtered (unique IDs - no repeats) B is a list of date times starting at 12/12/2021 06:30 (the first time and increasing by 15 minute intervals. I have already sorted this part out which works perfectly as I want it. What I don't know how to do is get those associated bits of Data in C:C to appear in the relevant cells.

12344444321
12/12/2021 06:30chickenlampoak
12/12/2021 06:45
12/12/2021 07:00
12/12/2021 07:15
12/12/2021 07:30blimp attack
….
13/12/2021 08:30extended warranty


I should specify I'm using VBA rather than formula for this as the data set is quite large (though not in the example of course), so I'm after a VBA solution :)

Thanks for any help!
 

BSALV

Active Member
Joined
Oct 31, 2010
Messages
303
Office Version
  1. 365
  2. 2013
  3. 2007
my version which is selflearning for the categories
VBA Code:
Sub MyVersion()
     Dim tijd(), sMyNames, Result()
     sMyNames = "Timestamp"                                     '1st columname
     sp = Split(sMyNames, "|")                                  'searcharray categories

     a = ActiveSheet.Range("A1").CurrentRegion.Resize(, 3).Value2     'read data
     mytimestamps = Application.Index(a, 0, 2)                  'all the timestamps
     mymin = Application.Min(mytimestamps)                      'smallest
     mymax = Application.Max(mytimestamps)                      'greatest
     Delta = (mymax - mymin) * 24 * 4 + 2                       'number of quarters in between
     ThisWorkbook.Names.Add "MyStart", mymin - 0.00000000000001     'smallest - a very small number
     tijd = [transpose(mystart+(row(a1:a65500)-1)*time(0,15,0))]     'max 65.500 quarters of almost 2 year
     ReDim Result(1 To Int(Delta), 1 To 4)                      'prepare Result-array

     For i = 1 To UBound(a)                                     'loop through the data
          r = Application.Match(a(i, 2), tijd, 1)               'find matching timestamp
          k = Application.Match(CStr(a(i, 1)), sp, 0)           'find matching category
          If Not IsNumeric(k) Then                              'category not found
               sMyNames = sMyNames & "|" & a(i, 1)              'add category to string
               sp = Split(sMyNames, "|")                        'array with categories
               k = Application.Match(CStr(a(i, 1)), sp, 0)      'matching column
               If UBound(Result, 2) < k Then ReDim Preserve Result(1 To UBound(Result), 1 To k)     'in case of not enough columns in the array
          End If
          Result(r, 1) = WorksheetFunction.MRound(tijd(r), 1 / 96)     'correct timestamp without tiny difference
          Result(r, k) = a(i, 3)                                'data
     Next

     arr = Application.Sort(Result, 1, -1)                      'sort array descending on timestamp (empty timestamp go in the back
     arr1 = Application.Transpose(Application.Index(arr, 0, 1))     'just the column with the timestamps
     r = Application.Match(0, arr1, -1)                         'find row of last valid timestamp

     With Range("G1")
          .Resize(, UBound(sp) + 1).Value = sp                  'the header
          With .Offset(1).Resize(r + 1, UBound(arr, 2))         'the range for the data
               .Value = arr                                     'writ the data
               .Sort .Range("A1"), Header:=xlNo                 'reverse the sort = timestamp ascending
          End With
     End With

End Sub
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
93
Office Version
  1. 365
Platform
  1. Windows
What stands out immediately to me is that you have 1234 as an id in the source and 1243 as a column name in the output. Double check the script you are using to generate the column names.

Ignore the following if you have already done the optimization step mentioned in my previous reply.
VBA Code:
Option Explicit
Sub sssssssss()
    Dim Main_CLCTN As New Collection, output() As Variant, Y As Long, _
    X As Long, Specified_Time_CLCTN As Collection, datetime_key As String, lastrow As Long
    Dim Destination_RNG As Range, data() As Variant, _
    id_code As String, schema() As Variant, Success_Count As Long, ids() as string
  
    Set Destination_RNG = ThisWorkbook.Worksheets("Sheet2").Range("B2") 'Thisworkbook.worksheets(" ").Range(" ")   Reference to top left cell of where you want the data            '
  
    With ActiveSheet
  
        lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
      
        data = .Range("A2", "C" & lastrow).Value
      
    End With
   
    With Main_CLCTN
      
       on error resume next
        For X = LBound(data, 1) To UBound(data, 1)
           
            datetime_key = data(X, 2)
            id_code = data(X, 1)
            .add new Collection,datetime_key
           
            'On Error GoTo Missing_Key
           
            .Item(datetime_key).Add data(X, 3), id_code
Next_Row_Parse:
        Next X
    End With
    schema = ThisWorkbook.Worksheets("Sheet2").UsedRange.Value
   
    redim ids(1 to ubound(schema,2))
    for x=lbound(schema,2) +1 to ubound(schema,2)
        ids(x-1)=cstr(schema(1,x))
    next x
    ReDim output(1 To UBound(schema, 1) - 1, 1 To UBound(schema, 2) - 1)
   
    With Main_CLCTN
  
        For X = LBound(schema, 1) + 1 To UBound(schema, 1)
           
            On Error GoTo output_creation_date_missing
           
            Set Specified_Time_CLCTN = .Item(CStr(CDate(schema(X, 1))))
           
            On Error Resume Next
           
            With Specified_Time_CLCTN
           
                If .Count > 0 Then
                   
                    For Y = LBound(ids)  To UBound(ids)
                       
                        output(X - 1, Y) = .Item(ids(y))
                       
                        If Err.Number = 0 Then
                            Success_Count = Success_Count + 1
                            If Success_Count = .Count Then Exit For
                        Else
                            Err.Clear
                        End If
                       
                    Next Y
                   
                    Success_Count = 0
                   
                End If
               
            End With
           
output_creation_next_row:
        Next X
   
    End With
   
    On Error GoTo 0
   
    Destination_RNG.Resize(UBound(output, 1), UBound(output, 2)).Value = output
Exit Sub
Missing_Key:
    Resume Next_Row_Parse
 
output_creation_date_missing:
    Resume output_creation_next_row
End Sub
Hi :)

I fixed the rather embarrassing typo - think I'd been looking at the sheet to long to see what was in front of my own face - however, the issue still exists unfortunately.

I'm using the optimized version of the code from your last post too :)
 

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
397
Office Version
  1. 2016
Platform
  1. Windows
Hi :)

I fixed the rather embarrassing typo - think I'd been looking at the sheet to long to see what was in front of my own face - however, the issue still exists unfortunately.

I'm using the optimized version of the code from your last post too :)
If you kept it as is in your previous reply then you are missing a 6:00 AM value to match it to in the output location. I think post #13 does what you want it, since it both generates the axes and assigns row values.
 

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
93
Office Version
  1. 365
Platform
  1. Windows
If you kept it as is in your previous reply then you are missing a 6:00 AM value to match it to in the output location. I think post #13 does what you want it, since it both generates the axes and assigns row values.
I found the issue - my source data had no headers and I believe the code you supplied treats it as though it does and ignores row 1 from the source data :) I'm glad I identified my issue - I was beginning to think I knew absolutely nothing about VBA at all any longer :) Thanks for all your help and suggestions - hopefully I won't have too many more questions or errors to bug you with :)

Also, I had a go with the code from #13 and I appreciate all responses enormously :) In this case though - I don't actually want the axes and row values assigned as they already exist on the output sheet... which, having looked at a lot of the suggestions here, is kind of annoying. I probably *should* do it the way everyone has suggested where all the data (and axes) are done together, and then do what I need to do to the axes info *second* rather than *first* - though I appreciate that probably doesn't make much sense given you can't actually see everything that I'm trying to do lol.

tl;dr I should re-evaluate my flow and this entire thread has taught me rather a lot :)
 

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
93
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

my version which is selflearning for the categories
VBA Code:
Sub MyVersion()
     Dim tijd(), sMyNames, Result()
     sMyNames = "Timestamp"                                     '1st columname
     sp = Split(sMyNames, "|")                                  'searcharray categories

     a = ActiveSheet.Range("A1").CurrentRegion.Resize(, 3).Value2     'read data
     mytimestamps = Application.Index(a, 0, 2)                  'all the timestamps
     mymin = Application.Min(mytimestamps)                      'smallest
     mymax = Application.Max(mytimestamps)                      'greatest
     Delta = (mymax - mymin) * 24 * 4 + 2                       'number of quarters in between
     ThisWorkbook.Names.Add "MyStart", mymin - 0.00000000000001     'smallest - a very small number
     tijd = [transpose(mystart+(row(a1:a65500)-1)*time(0,15,0))]     'max 65.500 quarters of almost 2 year
     ReDim Result(1 To Int(Delta), 1 To 4)                      'prepare Result-array

     For i = 1 To UBound(a)                                     'loop through the data
          r = Application.Match(a(i, 2), tijd, 1)               'find matching timestamp
          k = Application.Match(CStr(a(i, 1)), sp, 0)           'find matching category
          If Not IsNumeric(k) Then                              'category not found
               sMyNames = sMyNames & "|" & a(i, 1)              'add category to string
               sp = Split(sMyNames, "|")                        'array with categories
               k = Application.Match(CStr(a(i, 1)), sp, 0)      'matching column
               If UBound(Result, 2) < k Then ReDim Preserve Result(1 To UBound(Result), 1 To k)     'in case of not enough columns in the array
          End If
          Result(r, 1) = WorksheetFunction.MRound(tijd(r), 1 / 96)     'correct timestamp without tiny difference
          Result(r, k) = a(i, 3)                                'data
     Next

     arr = Application.Sort(Result, 1, -1)                      'sort array descending on timestamp (empty timestamp go in the back
     arr1 = Application.Transpose(Application.Index(arr, 0, 1))     'just the column with the timestamps
     r = Application.Match(0, arr1, -1)                         'find row of last valid timestamp

     With Range("G1")
          .Resize(, UBound(sp) + 1).Value = sp                  'the header
          With .Offset(1).Resize(r + 1, UBound(arr, 2))         'the range for the data
               .Value = arr                                     'writ the data
               .Sort .Range("A1"), Header:=xlNo                 'reverse the sort = timestamp ascending
          End With
     End With

End Sub
Hi, thanks for this suggestion :)

I get an error on line 24 - a type mismatch for Result(r, 1) - I'll see if I can find out anything further
 

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
93
Office Version
  1. 365
Platform
  1. Windows
Hi, thanks for this suggestion :)

I get an error on line 24 - a type mismatch for Result(r, 1) - I'll see if I can find out anything further
okay - so stepping through the code and watching locals

r & k = error 2042 after line 16 and 17
 

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
93
Office Version
  1. 365
Platform
  1. Windows
okay - so stepping through the code and watching locals

r & k = error 2042 after line 16 and 17
Managed to fix this issue - however I don't believe the code supplied creates uniques for the categories (unless I've messed something up somewhere) for example 4444 appears more that once in row 1
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,579
Messages
5,765,208
Members
425,265
Latest member
bishopc22

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
Top