Sub Construct_Table()
Dim H_arry() As String
Dim site_id As Range
Dim rpt_cfg As Variant
Dim lookUp_Arry1() As Variant
Dim lookUp_Arry2() As Variant
Dim lr As Long
Dim lr1 As Long
Dim lr2 As Long
Dim lr3 As Integer
Dim lc As Integer
Dim lc1 As Integer
Dim lc2 As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim match_ As Variant
Dim switch_ As Boolean
Application.ScreenUpdating = False
rpt_cfg = Array(3, 23, 27, 28, 30, 31) 'Report Config
With ThisWorkbook
Set ws1 = .Worksheets("ReportConfig")
Set ws2 = .Worksheets("MeasurementIdentity")
Set ws3 = .Worksheets(3)
End With
ws3.UsedRange.Clear
lr1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lc1 = ws1.Cells(lr1, Columns.Count).End(xlToLeft).Column
lr2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
lc2 = ws2.Cells(lr2, Columns.Count).End(xlToLeft).Column
ws1.Range(ws1.Cells(1, 1), ws1.Cells(lr1, 1)).Copy ws3.Cells(1, 1)
ws3.Range(ws3.Cells(1, 1), ws3.Cells(lr1, 1)).RemoveDuplicates Columns:=1, Header:=xlYes
lr3 = ws3.Cells(2, 1).End(xlDown).Row
Set site_id = ws3.Range("A2:A" & lr3)
switch_ = False
For w = 1 To 2
With ThisWorkbook.Worksheets(w)
lr = .Range("A" & Rows.Count).End(xlUp).Row
lc = .Cells(lr, Columns.Count).End(xlToLeft).Column
For h = 3 To lc 'Store headers in arry from wksht 1 to 2
ReDim Preserve H_arry(j)
H_arry(j) = .Cells(1, h)
j = j + 1
Next h
For e = 1 To lr 'Concatenate 2 columns of an array to use as a look-up range
If switch_ = False Then
ReDim Preserve lookUp_Arry1(f)
lookUp_Arry1(f) = Application.Index(.UsedRange, e, 1) & " " & Application.Index(.UsedRange, e, 2)
f = f + 1
Else
ReDim Preserve lookUp_Arry2(f)
lookUp_Arry2(f) = Application.Index(.UsedRange, e, 1) & " " & Application.Index(.UsedRange, e, 2)
f = f + 1
End If
Next e
switch_ = True
f = 0
End With
Next w
switch_ = False
y = 2
For r = LBound(rpt_cfg) To UBound(rpt_cfg) 'Write headers to worksheet 3
For h = LBound(H_arry) To UBound(H_arry) 'switches between 2 different sequence in a set of headers for each r.
If h < (lc1 - 2) Then
ws3.Cells(1, y) = "Report Config" & rpt_cfg(r) & vbCrLf & H_arry(h)
y = y + 1
Else
ws3.Cells(1, y) = H_arry(h) & vbCrLf & "(Report Config" & rpt_cfg(r) & ")"
y = y + 1
End If
Next h
Next r
a = 2
b = 2
r = 0
For Each site In site_id 'Copy values to worksheet 3
Do While b <> y
For w = 1 To 2
With ThisWorkbook.Worksheets(w)
If switch_ = False Then
match_ = Application.Match(site.Value & " " & rpt_cfg(r), lookUp_Arry1, 0)
If Not IsError(match_) Then
.Range(.Cells(match_, 3), .Cells(match_, lc1)).Copy ws3.Cells(a, b)
b = b + (lc1 - 3) + 1
switch_ = True
Else
ws3.Range(ws3.Cells(a, b), ws3.Cells(a, b).Offset(0, (lc1 - 3))).Value = "Not Found"
b = b + (lc1 - 3) + 1
switch_ = True
End If
Else
match_ = Application.Match(site.Value & " " & rpt_cfg(r), lookUp_Arry2, 0)
If Not IsError(match_) Then
.Range(.Cells(match_, 3), .Cells(match_, lc2)).Copy ws3.Cells(a, b)
b = b + (lc2 - 3) + 1
switch_ = False
Else
ws3.Range(ws3.Cells(a, b), ws3.Cells(a, b).Offset(0, (lc2 - 3))).Value = "Not Found"
b = b + (lc2 - 3) + 1
switch_ = False
End If
End If
End With
Next w
r = r + 1
Loop
a = a + 1
b = 2
r = 0
Next
With ws3
.Columns.AutoFit
.Activate
.Cells(2, 2).Select
End With
ActiveWindow.FreezePanes = True
Erase H_arry
Erase rpt_cfg
Erase lookUp_Arry1
Erase lookUp_Arry2
Application.ScreenUpdating = True
End Sub
