I have data that always changes also it doesn't have the headers.

Like here I have data in 7 rows (The count of the rows can change every time.) ?

Now I want to filter in the 2nd column with the value Sub-Catg. which always be available in the 2nd column.

The filtered data will look like this ?

The number of rows and columns can vary every time in each data set.

Now I want to copy the data of filtered all the rows and pastes in the below format. ?

CodePudding user response：

Transpose (Unpivot) Data (VBA)

Option Explicit

Sub TransposeData()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sCol As Long = 2
    Const sCriterion As String = "Sub-Catg."
    ' Destination
    Const dName As String = "Sheet2"
    Const dfCellAddress As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim surg As Range: Set surg = sws.UsedRange
    Dim scrCount As Long
    scrCount = Application.CountIf(surg.Columns(sCol), sCriterion)
    If scrCount = 0 Then Exit Sub ' no criterion found
    Dim scCount As Long: scCount = surg.Columns.Count
    If scCount <= sCol Then Exit Sub ' no data after criteria column
    Dim sData As Variant: sData = surg.Value
    
    ' Destination
    ' 'drCount' is actually the maximum possible number of rows.
    ' The result will probably have fewer ('dr').
    Dim drCount As Long: drCount = scrCount * (scCount - sCol)
    Dim dcCount As Long: dcCount = sCol   1
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    Dim dr As Long: dr = 1
    
    Dim sValue As Variant
    Dim sr As Long
    Dim sc As Long
    Dim cdr As Long
    Dim dc As Long
    
    ' Write to destination array ('dData')
    For sr = 1 To UBound(sData, 1)
        If CStr(sData(sr, sCol)) = sCriterion Then ' criterion found
            cdr = dr
            ' Write after criterion.
            ' Looping until the last column allows blanks in-between
            ' at the cost of the code being a little slower.
            For sc = sCol   1 To scCount
                If Len(CStr(sData(sr, sc))) > 0 Then
                    dData(dr, dcCount) = sData(sr, sc)
                    dr = dr   1
                End If
            Next sc
            If dr > cdr Then ' values after criterion found
                ' Write criterion and before.
                For sc = 1 To sCol
                    dData(cdr, sc) = sData(sr, sc)
                Next sc
            'Else ' no value after criterion found
            End If
        'Else ' criterion not found
        End If
    Next sr
    
    If dr = 1 Then Exit Sub ' no values found
    dr = dr - 1
     
    ' Write to destination range.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dfCellAddress).Resize(, dcCount)
        ' Write to range.
        .Resize(dr).Value = dData
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - dr   1).Offset(dr).Clear
    End With

    MsgBox "Data transposed.", vbInformation

End Sub