Filling in data from source

L

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
244
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!
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sort by date Sort by votes
Is there data in source column C for all rows? Which would mean that every row in the new data format will have minimum 1 "C-data", yes?
 
Upvote 0
Engberg said:
Is there data in source column C for all rows? Which would mean that every row in the new data format will have minimum 1 "C-data", yes?
Click to expand...
Yes :) C will always have an entry of some sort usually a number but could also be string - blanks have been entire.row removed as part of the pre-existing preparation I have done :)
 
Upvote 0
This is a formula and not per your request a VBA solution.
You might be simply able to convert this to VBA if this isn't OK. I ran it with 3000+ rows in the result sheet and it was instantaneous.

Book7
ABCD
1Date/Time12344444321
212/12/2021 6:30chickenlampoak
312/12/2021 6:45   
412/12/2021 7:00   
512/12/2021 7:15   
612/12/2021 7:30   
712/15/2021 7:30blimp attack  
812/15/2021 7:45   
91/10/2022 8:30extended warranty  
Result
Cell Formulas
RangeFormula
B1:D1B1=TRANSPOSE(UNIQUE(Source!A1:A5))
B2:D9B2=FILTER(Source!$C$1:$C$5,($A2=Source!$B$1:$B$5)*(Source!$A$1:$A$5=B$1),"")
A2A2=Source!B1
A3:A6,A8A3=A2+15/1440
Dynamic array formulas.
 
Last edited:
Upvote 0
If you want a pure VBA solution, here's one that I think works now.
You need:
  • Two sheets. The first sheet contains your data with the original formatting, "pasted at" A1. The second sheet contains your part ID:s and date/times formatted as in your image.
sheet 1
sheet 2


Running the script below will populate sheet 2 with the "C-data" from sheet 1.

VBA Code: 
Sub orderData()

    Dim oldCoords As Collection
    Dim newCoords As Collection
    Set oldCoords = New Collection
    Set newCoords = New Collection
    
    With ThisWorkbook.Worksheets(1)
    lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
    
    For r = 1 To lastRow
        oldCoords.Add Array(.Cells(r, "A"), .Cells(r, "B"))
    Next
    End With
    
    With ThisWorkbook.Worksheets(2)
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    For Each Item In oldCoords
        vArr = Split(Cells(1, lastCol).Address(True, False), "$")
        col_letter = vArr(0)
        Dim item_id As Range
        Set item_id = .Range("A1:" & col_letter & lastRow).Find(Item(0))  'Find first element in oldCoords, which is part ID
      
        Dim time As Range
        Set time = .Range("A1:A" & lastRow).Find(Item(1)) 'Find second element in oldCoords, which is the timestamp
        
        newCoords.Add Array(item_id.Column, time.Row)
    Next
    End With
    
    With ThisWorkbook.Worksheets(1)
    i = 1
    For Each Item In newCoords 'For each pair of new coordinates, "copy" C-data from old format to new format
        vArr = Split(Cells(1, Item(0)).Address(True, False), "$")
        col_letter = vArr(0)
        ThisWorkbook.Worksheets(2).Range(vArr(0) & Item(1)) = .Range("C" & i)
        i = i + 1
    Next

    End With

End Sub

Let me know how it runs :)
 
Upvote 0
VBA Code: 
Sub sssssssss()
    Dim Main_CLCTN As New Collection, output() As Variant, Y As Long, IDs As New Collection, _
    X As Long, Specified_Time_CLCTN As Collection, datetime_key As String, Temp() As Variant, lastrow As Long
    
    
    Dim Destination_RNG As Range,Start_Time as date,End_Time as date
    
    set destination_rng= '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
    Start_Time = data(1, 2)
    end_time = data(UBound(data, 1), 2)
    
    With Main_CLCTN
        new_time = Start_Time
        
        Do  'Create a new collection for each 15 min interval from start time to end time
        
            datetime_key = new_time
            
            Set Specified_Time_CLCTN = New Collection
            Specified_Time_CLCTN.AMain_CLCTN datetime_key, "Time"
            .AMain_CLCTN Specified_Time_CLCTN, datetime_key
            new_time = DateAMain_CLCTN("n", 15, new_time)
            
        Loop Until new_time > end_time
        For X = LBound(data, 1) To UBound(data, 1)
        
            datetime_key = data(X, 2)
            .Item(datetime_key).AMain_CLCTN Array(data(X, 3), CStr(data(X, 1))) 'Array is (Associated term,ID to be used as key)
            
            On Error Resume Next
                'Populate collection with unique IDS to be used as headers and to specify array column location
                IDs.AMain_CLCTN Array(IDs.Count + 2, data(X, 1)), CStr(data(X, 1)) 'Array is (column number for final array,ID) keyed to ID
            On Error GoTo 0
            
        Next X
        ReDim output(1 To .Count + 1, 1 To IDs.Count + 1)
        
    End With
    With IDs 'Fill in ID numbers at top
        For X = 1 To .Count
            output(1, X + 1) = .Item(X)(1) 'ID
        Next X
    End With
    
    With Main_CLCTN 'Create output array
        
        For X = 1 To .Count
            
            With .Item(X) 'With Time collection
                
                output(X + 1, 1) = .Item("Time")
                
                If .Count > 1 Then
                    For Y = 2 To .Count          '1st item is "Time" so start at 2
                        Temp = .Item(Y)
                        output(X + 1, IDs(Temp(1))(0)) = Temp(0)
                        'get column number from ID collection by using the stored ID as a key
                    Next Y  
                End If
                
            End With
        Next X
        
    End With
    
    Destination_RNG.Resize(UBound(output, 1), UBound(output, 2)).value = output
End Sub
 
Last edited:
Upvote 0
MoshiM said:
VBA Code: 
Option Explicit

Sub sssssssss()
    Dim Main_CLCTN As New Collection, output() As Variant, Y As Long, IDs As New Collection, _
    X As Long, Specified_Time_CLCTN As Collection, datetime_key As String, Temp() As Variant, lastrow As Long
  
  
    Dim Destination_RNG As Range, Start_Time As Date, End_Time As Date, data() As Variant, new_date As Date
  
    set destination_rng= '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
    Start_Time = data(1, 2)
    End_Time = data(UBound(data, 1), 2)
  
    With Main_CLCTN
  
        new_date = Start_Time
      
        Do  'Create a new collection for each 15 min interval from start time to end time
      
            datetime_key = new_date
          
            Set Specified_Time_CLCTN = New Collection
          
            Specified_Time_CLCTN.Add datetime_key, "Time"
          
            Main_CLCTN.Add Specified_Time_CLCTN, datetime_key
          
             new_date = DateAdd("n", 15, new_date)
          
        Loop Until new_date > End_Time
      
        For X = LBound(data, 1) To UBound(data, 1)
      
            datetime_key = data(X, 2)
            .Item(datetime_key).Add Array(data(X, 3), CStr(data(X, 1))) 'Array is (Associated term,ID to be used as key)
          
            On Error Resume Next
                'Populate collection with unique IDS to be used as headers and to specify array column location
                IDs.Add Array(IDs.Count + 2, data(X, 1)), CStr(data(X, 1)) 'Array is (column number for final array,ID) keyed to ID
            On Error GoTo 0
          
        Next X
        ReDim output(1 To .Count + 1, 1 To IDs.Count + 1)
      
    End With
    With IDs 'Fill in ID numbers at top
        For X = 1 To .Count
            output(1, X + 1) = .Item(X)(1) 'ID
        Next X
    End With
  
    With Main_CLCTN 'Create output array
      
        For X = 1 To .Count
          
            With .Item(X) 'With Time collection
              
                output(X + 1, 1) = .Item("Time")
              
                If .Count > 1 Then
                    For Y = 2 To .Count          '1st item is "Time" so start at 2
                        Temp = .Item(Y)
                        output(X + 1, IDs(Temp(1))(0)) = Temp(0)
                        'get column number from ID collection by using the stored ID as a key
                    Next Y
                End If
              
            End With
        Next X
      
    End With
  
    Destination_RNG.Resize(UBound(output, 1), UBound(output, 2)).value = output
End Sub
Click to expand...
Oops find and replace did a number on that one. Use this:
VBA Code: 
Option Explicit

Sub sssssssss()
    Dim Main_CLCTN As New Collection, output() As Variant, Y As Long, IDs As New Collection, _
    X As Long, Specified_Time_CLCTN As Collection, datetime_key As String, Temp() As Variant, lastrow As Long
   
   
    Dim Destination_RNG As Range, Start_Time As Date, End_Time As Date, data() As Variant, new_date As Date
   
    set destination_rng= '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
    Start_Time = data(1, 2)
    End_Time = data(UBound(data, 1), 2)
   
    With Main_CLCTN
   
        new_date = Start_Time
       
        Do  'Create a new collection for each 15 min interval from start time to end time
       
            datetime_key = new_date
           
            Set Specified_Time_CLCTN = New Collection
           
            Specified_Time_CLCTN.Add new_date, "Time"
           
            .Add Specified_Time_CLCTN, datetime_key
           
            new_date = DateAdd("n", 15, new_date)
           
        Loop Until new_date > End_Time
       
        For X = LBound(data, 1) To UBound(data, 1)
       
            datetime_key = data(X, 2)
            .Item(datetime_key).Add Array(data(X, 3), CStr(data(X, 1))) 'Array is (Associated term,ID to be used as key)
           
            On Error Resume Next
                'Populate collection with unique IDS to be used as headers and to specify array column location
                IDs.Add Array(IDs.Count + 2, data(X, 1)), CStr(data(X, 1)) 'Array is (column number for final array,ID) keyed to ID
            On Error GoTo 0
           
        Next X
        ReDim output(1 To .Count + 1, 1 To IDs.Count + 1)
       
    End With
    With IDs 'Fill in ID numbers at top
        For X = 1 To .Count
            output(1, X + 1) = .Item(X)(1) 'ID
        Next X
    End With
   
    With Main_CLCTN 'Create output array
       
        For X = 1 To .Count
           
            With .Item(X) 'With Time collection
               
                output(X + 1, 1) = .Item("Time")
               
                If .Count > 1 Then
                    For Y = 2 To .Count          '1st item is "Time" so start at 2
                        Temp = .Item(Y)
                        output(X + 1, IDs(Temp(1))(0)) = Temp(0)
                        'get column number from ID collection by using the stored ID as a key
                    Next Y
                End If
               
            End With
        Next X
       
    End With
   
    Destination_RNG.Resize(UBound(output, 1), UBound(output, 2)).value = output
End Sub
 
Upvote 0
An alternative is to use power query.

Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(Source, {{"Column1", type text}}, "en-US"), List.Distinct(Table.TransformColumnTypes(Source, {{"Column1", type text}}, "en-US")[Column1]), "Column1", "Column3")
in
    #"Pivoted Column"

Book10
ABCDEFGH
1Column1Column2Column3Column212344444321
2123412/12/2021 6:30chicken12/12/2021 6:30chickenlampoak
3444412/12/2021 6:30lamp12/12/2021 7:30blimp attack
432112/12/2021 6:30oak12/13/2021 8:30extended warranty
5123412/12/2021 7:30blimp attack
6123412/13/2021 8:30extended warranty
Sheet1
 
Upvote 0
Thanks for the responses everyone!

I'm reviewing the options you've all provided to see which works for me best :)

I'll report back on which I go with/any issues I run into :)
 
Upvote 0
Engberg said:
If you want a pure VBA solution, here's one that I think works now.
You need:
  • Two sheets. The first sheet contains your data with the original formatting, "pasted at" A1. The second sheet contains your part ID:s and date/times formatted as in your image.
View attachment 54734View attachment 54735

Running the script below will populate sheet 2 with the "C-data" from sheet 1.

VBA Code: 
Sub orderData()

    Dim oldCoords As Collection
    Dim newCoords As Collection
    Set oldCoords = New Collection
    Set newCoords = New Collection
   
    With ThisWorkbook.Worksheets(1)
    lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
   
    For r = 1 To lastRow
        oldCoords.Add Array(.Cells(r, "A"), .Cells(r, "B"))
    Next
    End With
   
    With ThisWorkbook.Worksheets(2)
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    For Each Item In oldCoords
        vArr = Split(Cells(1, lastCol).Address(True, False), "$")
        col_letter = vArr(0)
        Dim item_id As Range
        Set item_id = .Range("A1:" & col_letter & lastRow).Find(Item(0))  'Find first element in oldCoords, which is part ID
     
        Dim time As Range
        Set time = .Range("A1:A" & lastRow).Find(Item(1)) 'Find second element in oldCoords, which is the timestamp
       
        newCoords.Add Array(item_id.Column, time.Row)
    Next
    End With
   
    With ThisWorkbook.Worksheets(1)
    i = 1
    For Each Item In newCoords 'For each pair of new coordinates, "copy" C-data from old format to new format
        vArr = Split(Cells(1, Item(0)).Address(True, False), "$")
        col_letter = vArr(0)
        ThisWorkbook.Worksheets(2).Range(vArr(0) & Item(1)) = .Range("C" & i)
        i = i + 1
    Next

    End With

End Sub

Let me know how it runs :)
Click to expand...
Hi!

Thank you for the help!

I'm currently getting "run time error 91 object variable or with block variable not set" for the line

VBA Code: 
newCoords.Add Array(item_id.Column, time.Row)

specifically "time.row"
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Extract Dates from 2 columns
Replies
2
Views
301
Peter_SSs
Peter_SSs
T
  • Solved
Date of Max value
Replies
5
Views
171
Fluff
Fluff
M
  • Question
Best solution to consolidate values that occur on multiple dates/lines
Replies
5
Views
263
Peter_SSs
Peter_SSs
S
  • Question
Date column not working
Replies
4
Views
476
awoohaw
awoohaw
E
  • Question
Count filtered unique values where sum of values in another column meets criteria
Replies
9
Views
599
excelhelppleas
E

Forum statistics

Threads
1,214,641
Messages
6,120,691
Members
448,978
Latest member
rrauni

Share this page

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