VBA: Match timeseries [date value] to a common datevector, creating a single matrix

I'm trying to write a code in VBA taking a number of timeseries and inserting them into single matrix. With the dates to the left, and data right of it.

It has to be VBA and fast since i am dealing with huge amounts of data

Example:
................serie 1..........
2005-06-20 147
2005-06-27 144,5
2005-07-04 145


...............serie 2.....serie 3................
2005-06-24 6670 40,9
2005-06-27 6630 41,28
2005-06-28 6660 41,72
2005-06-29 6832 41,85

I want to create:
Combined dates....serie1....serie2....serie 3
2005-06-20 147 empty empty
2005-06-24 empty 6670 40,9
2005-06-27 144,5 6630 41,28
2005-06-28 empty 6660 41,72
2005-06-29 empty 6832 41,85
2005-07-04 145 empty empty

That is: i want to combine the timeseries into a common matrix.

My first thought to do it was to

1. Create a common datevector of all the dates available

1. Remove duplicates

1. Match the data to the specific dates using VLOOKUP in some way (not yet achieved)

Is there any better way of doing it? How do i write it?

Right now i have created a single datevector without duplicates, i.e.:

2005-06-20
2005-06-24
2005-06-27
2005-06-28
2005-06-29
2005-07-04


I will be thrilled for any suggestions and responses

Hi

Assumptions:
The first series is on sheet1, columns A:B, headings in row 1
The second set of data is on sheet2, columns A:C, headings in row 1
Sheet3 exists, with headings in row 1

The code below will copy to sheet3 and sort on column A.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet3")
  
  Sheets("sheet1").Activate
  Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Destination:=OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  
  Sheets("Sheet2").Activate
  Range("B:B").EntireColumn.Insert
  Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Destination:=OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  Range("B:B").EntireColumn.Delete
  
  OutSH.Activate
  Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Sort key1:=Range("A1"), order1:=xlAscending, header:=xlYes
  
End Sub

HTH

rylo

Originally Posted by rylo

Hi

Assumptions:
The first series is on sheet1, columns A:B, headings in row 1
The second set of data is on sheet2, columns A:C, headings in row 1
Sheet3 exists, with headings in row 1

The code below will copy to sheet3 and sort on column A.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet3")
  
  Sheets("sheet1").Activate
  Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Destination:=OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  
  Sheets("Sheet2").Activate
  Range("B:B").EntireColumn.Insert
  Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Destination:=OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  Range("B:B").EntireColumn.Delete
  
  OutSH.Activate
  Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Sort key1:=Range("A1"), order1:=xlAscending, header:=xlYes
  
End Sub

HTH

rylo

But will that take care of the duplicates? Example:

2005-07-04 empty 7160
2005-07-05 144 empty
2005-07-05 empty 7060
2005-07-06 empty 7293

I dont want two instances of 2005-07-05. They have to be on the same row

Hi

Sorry, forgot about the duplicates.

Make sure that there is nothing on sheet3 (no headings etc). Sheets 1 and 2 have headings in row 1 and data starting in A2.

See how this goes.

Sub bbb()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet3")
  OutSH.Cells.ClearContents
  
  Dim nodupes As New Collection
  On Error Resume Next
  With Sheets("sheet1")
    For Each ce In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
      nodupes.Add Item:=ce.Value, key:=CStr(ce.Value)
    Next ce
  End With
  
  With Sheets("sheet2")
    For Each ce In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
      nodupes.Add Item:=ce.Value, key:=CStr(ce.Value)
    Next ce
  End With
  On Error GoTo 0
  
  OutSH.Range("A1").Value = Sheets("Sheet1").Range("A1").Value
  For i = 1 To nodupes.Count
    OutSH.Range("A1").Offset(i, 0).Value = nodupes(i)
  Next i
  OutSH.Range("A1").CurrentRegion.Sort key1:=OutSH.Range("A1"), order1:=xlAscending, header:=xlYes
  
  OutSH.Range("B1").Value = Sheets("Sheet1").Range("B1").Value
  OutSH.Range("C1:D1").Value = Sheets("Sheet2").Range("B1:C1").Value
  
  Set rng = OutSH.Range("A2:A" & OutSH.Cells(Rows.Count, 1).End(xlUp).Row)
  
  With Sheets("sheet1")
    For Each ce In rng
      Set findit = .Range("A:A").Find(what:=ce)
      If Not findit Is Nothing Then ce.Offset(0, 1).Value = findit.Offset(0, 1).Value
    Next ce
  End With
  
  With Sheets("sheet2")
    For Each ce In rng
      Set findit = .Range("A:A").Find(what:=ce)
      If Not findit Is Nothing Then
        ce.Offset(0, 2).Value = findit.Offset(0, 1).Value
        ce.Offset(0, 3).Value = findit.Offset(0, 2).Value
      End If
    Next ce
  End With
  
End Sub

rylo

Great posting. Thank you very much.