Excel VBA ARRAY Loop to Database - arrays

Question

I have a huge challenge which is: Search a massive database, a list of products. This database is divided into 3 dif. sheets. The result should be stored on a 4th sheet and organized by date in columns and summarized by quantity. Each database sheet has the same format (Product / Date / Quantity).
I was told that a vba array would work perfectly.
Any help will be very appreciated.
Thanksenter image description here

Answer 1

Pivot (Multiple Worksheets)
The Code
Option Explicit
Sub PivotMulti()
' Data
Const srcList As String = "Sheet1,Sheet2,Sheet3"
Const srcFirst As String = "A2"
' Destination
Const dstName As String = "SUMMARY"
Const dstFirst As String = "B2"
Const TitlesList As String = "Source Data,Product"
' Other
Const Delimiter As String = "###"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Data Ranges and write their values to arrays of Data Array.
Dim srcNames() As String: srcNames = Split(srcList, ",")
Dim sUpper As Long: sUpper = UBound(srcNames)
Dim Data As Variant: ReDim Data(0 To sUpper)
Dim rng As Range
Dim dCount As Long
Dim n As Long
For n = 0 To sUpper
With wb.Worksheets(srcNames(n)).Range(srcFirst)
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
Data(n) = .Resize(rng.Row - .Row + 1, 3).Value
dCount = dCount + UBound(Data(n))
End With
Next n
' Define data structures.
Dim dictS As Object: Set dictS = CreateObject("Scripting.Dictionary")
dictS.CompareMode = vbTextCompare
Dim dictD As Object: Set dictD = CreateObject("Scripting.Dictionary")
Dim arlS As Object: Set arlS = CreateObject("System.Collections.ArrayList")
Dim arlD As Object: Set arlD = CreateObject("System.Collections.ArrayList")
' Declare additional variables.
Dim CurrString As String
Dim CurrDate As Date
Dim i As Long
Dim j As Long
Dim k As Long
' Write values from Data Array to dictionaries and array lists
' (dictianaries for 'unique' and 'sum', array lists for 'sort').
For n = 0 To sUpper
For i = 1 To UBound(Data(n), 1)
CurrDate = Data(n)(i, 2)
If Not dictD.Exists(CurrDate) Then
arlD.Add CurrDate
dictD(CurrDate) = Empty
End If
CurrString = Data(n)(i, 1) & Delimiter & srcNames(n) & Delimiter _
& Format(CurrDate, "yyyymmdd") & Delimiter & CurrDate
dictS(CurrString) = dictS(CurrString) + Data(n)(i, 3)
Next i
Next n
Set dictD = Nothing
Erase Data
Erase srcNames
arlD.Sort
Dim Key As Variant
For Each Key In dictS.Keys
arlS.Add Key & Delimiter & dictS(Key)
Next Key
Set dictS = Nothing
arlS.Sort
' Define Result Array.
Dim rrCount As Long: rrCount = 1 + arlS.Count
Dim rcCount As Long: rcCount = 2 + arlD.Count
Dim Result As Variant: ReDim Result(1 To rrCount, 1 To rcCount)
' Write headers.
Dim Titles() As String: Titles = Split(TitlesList, ",")
Result(1, 1) = Titles(0)
Result(1, 2) = Titles(1)
Erase Titles
j = 2
For Each Key In arlD
j = j + 1
Result(1, j) = Key
Next Key
' Write 'body'.
Dim Current() As String
Dim Previous(0 To 1) As String
i = 1
For Each Key In arlS
i = i + 1
Current = Split(Key, Delimiter)
If Current(0) <> Previous(0) Or Current(1) <> Previous(1) Then
For j = 1 To 2
Result(i, j) = Current(2 - j)
Next j
Else
i = i - 1
End If
CurrDate = CDate(Current(3))
Result(i, 3 + arlD.IndexOf(CurrDate, 0)) = CDbl(Current(4))
Previous(0) = Current(0)
Previous(1) = Current(1)
Next Key
Set arlD = Nothing
Set arlS = Nothing
' Write values from Result Array to Destination Range.
With wb.Worksheets(dstName).Range(dstFirst).Resize(, rcCount)
Application.ScreenUpdating = False
' Worksheet
.Worksheet.Cells.Clear
' Range
With .Resize(i)
.Value = Result ' Write.
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
' Headers
.Font.Bold = True
.Interior.Color = vbYellow
' Body
With .Resize(i - 1).Offset(1)
'.Font.Color = vbRed
End With
' Columns
.Columns.AutoFit
Application.ScreenUpdating = True
End With
MsgBox "Data transferred.", vbInformation, "Success"
End Sub