Transpose and Vlookup for two different Sheet

[querylal]

Hi,

Workbook Master has 3 worksheet. Two worksheet as mentioned below and final worksheet need to create from other 2 by transpose and Vlookup.


Worksheet1: ReportConfig

[TABLE="width: 500, align: left"]
<tbody>[TR]
[TD]Site Id[/TD]
[TD]Report Config[/TD]
[TD]A3offset[/TD]
[TD]Hysteris[/TD]
[/TR]
[TR]
[TD]64001_1[/TD]
[TD]1[/TD]
[TD]2[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]64001_1[/TD]
[TD]3[/TD]
[TD]3[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]64001_1[/TD]
[TD]23[/TD]
[TD]4[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]64001_12[/TD]
[TD]1[/TD]
[TD]8[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]64001_12[/TD]
[TD]3[/TD]
[TD]2[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]64001_12[/TD]
[TD]23[/TD]
[TD]5[/TD]
[TD]6
[/TD]
[/TR]
</tbody>[/TABLE]











Worksheet2: MeasurementIdentity

[TABLE="width: 500"]
<tbody>[TR]
[TD]Site Id[/TD]
[TD]Report Config[/TD]
[TD]Measurement Identiy[/TD]
[TD]Measurement Object[/TD]
[/TR]
[TR]
[TD]64001_1[/TD]
[TD]1[/TD]
[TD]0[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]64001_1[/TD]
[TD]3[/TD]
[TD]3[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]64001_1[/TD]
[TD]23[/TD]
[TD]22[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]64001_12[/TD]
[TD]3[/TD]
[TD]3[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]64001_12[/TD]
[TD]1[/TD]
[TD]0[/TD]
[TD]0[/TD]
[/TR]
</tbody>[/TABLE]

Worksheet3: FinalWorksheet ( i want for report config 3,23,27,28,30,31 below parameter)


[TABLE="width: 400"]
<tbody>[TR]
[TD]Site Id[/TD]
[TD]Report Config 3 A3offset[/TD]
[TD]Report Config 3 Hysteris[/TD]
[TD]Measurement Identity (Report Config3)[/TD]
[TD]Measurement Object (Report Config3)[/TD]
[TD]ReportConfig23 A3Offset[/TD]
[TD]ReportConfig23 Hystersis[/TD]
[TD]Measurement Identity (Report Config23)[/TD]
[TD]Measurement Object (Report Config23)[/TD]
[/TR]
[TR]
[TD]64001_1[/TD]
[TD]2[/TD]
[TD]1[/TD]
[TD]3[/TD]
[TD]2[/TD]
[TD]4[/TD]
[TD]1[/TD]
[TD]22[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]64001_12[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]3[/TD]
[TD]1[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[querylal]

Can some one please help

 

[vbanoob0807]

Hi, the code below can help you get started, but it is not transpose and vlookup.

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

hopefully someone can suggest better solutions.

 

[querylal]

Thank you so much