Filling in data from source

[Luke777]

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

1234	12/12/2021 06:30	chicken
4444	12/12/2021 06:30	lamp
321	12/12/2021 06:30	oak
1234	12/12/2021 07:30	blimp attack
1234	13/12/2021 08:30	extended 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.

	1234	4444	321
12/12/2021 06:30	chicken	lamp	oak
12/12/2021 06:45
12/12/2021 07:00
12/12/2021 07:15
12/12/2021 07:30	blimp attack
….
13/12/2021 08:30	extended 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]

my version which is selflearning for the categories

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

 

[Luke777]

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.

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]

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]

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]

my version which is selflearning for the categories

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]

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]

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