Copy, paste data based on a particular criteria

[bonny24tycoon]

Hi Team,

I've been away for a month or so.. How are you all? Did I miss any fun??

My query -

I have a survey raw data; however, only need some specific info. Attached example sheet - Sample.xlsm

Some information before we start -

1. RawData Sheet: This is the actual dump of the data. Remember, column after SITE are the names of the categories. They contain either 1(Yes) or 0(No)

2. Final Sheet: This is the sheet where I need the output with the mentioned format. I am looking to populate the category name here based on the raw data given.

3. Every row has a Unique ID.

4. Every Unique ID can have 1 in multiple columns/headers.

5. There can be more than 5000 to 10000 Unique ID's and 100 Categories/ Yellow highlighted columns.

I need a VBA to do the following -

1. For every Unique ID it should identify the categories/yellow highlighted columns containing a "1"

2. Copy the Unique ID, Name and Site alongwith the Concatenated column header names that contained a "1".

For Eg (with the attached example) -

Unique ID 2 - has "1" only under "Diapers" and "Feminine Care". So in sheet "Final", you would need to paste the row information i.e Unique ID, Name, Site and the concatenated headers "Diapers, Feminine Care".

I hope I was able to explain this to its best.

[mike7952]

See if this will work you?

Sub abc()
 Const shRaw As String = "RawData" '<=== Change for your needs
 Const shOutput As String = "Final" '<=== Change for your needs
 Dim arrResults As Variant, a
 Dim i As Long, ii As Long
 
 
 With Worksheets(shRaw)
    a = .Range("a1").CurrentRegion
 End With
 
 ReDim arrResults(1 To UBound(a), 1 To 4)
 For i = 1 To UBound(a)
    arrResults(i, 1) = a(i, 1)
    arrResults(i, 2) = a(i, 2)
    arrResults(i, 3) = a(i, 3)
    For ii = 4 To UBound(a, 2)
        If a(i, ii) = 1 Then
            arrResults(i, 4) = arrResults(i, 4) & a(1, ii) & " ,"
        End If
    Next
    If Not IsEmpty(arrResults(i, 4)) Then
        arrResults(i, 4) = Left(arrResults(i, 4), Len(arrResults(i, 4)) - 2)
    End If
 Next
 With Worksheets(shOutput)
    Cells.Clear
    With Range("a1").Resize(UBound(a), 4)
        .Value = arrResults
        .Borders.LineStyle = xlContinuous
    End With
    .Range("d1") = "Category"
    .Cells.EntireColumn.AutoFit
 End With
End Sub