Simple macro to copy header of column where there is a 1

[Muktar888]

HI All,

I am looking for a macro to assist with a task that needs to loop through the set of rows in a well organised data set (sheet1). from row 2, the code needs to check if there is a "1" in a particular set of columns (K:Z);

If there is a "1", then make a copy of that rows contents from A:J with the header of the column where the "1" is found into the next sheet (A:K ie A:J = contents of that row from Sheet1 and K will inlcude the header of that column of Sheet 1 row 1.

There can be more than one "1" in a row, so it would need to check each cell in the row from column K to Z. when it gets to the next "1" it copy's contents of that row (A:J) into the next row row of Sheet2,

it stops the check at column Z then moves to the next row and then checks from column K again to see if there is a "1".

This is the data set (SHeet 1 ) above while below is what the end result should look like having iterated through row 2 and 3 manually.

File is also attached for full data set here: ---> File

 

[FracinDean]

I suggest you use a named range "activities" for columns K-Z and all the rows in your source datasheet, . Then in your macro, you will define a variable "c" as a range, define another range equal to the named range in your sheet, and loop through all the k values. You can use the row property of value c to get the input row, such as "c.Row" and work with the Cells method to define the first range you want to copy, and you can use the value of "c.Column" to find the value that you want to copy. Something like what I wrote below, but I left some rows for you to finish:

Sub ParseActivities()
Dim c as Range
Dim activityCodes as Range
Dim outputRow as Integer
Set activityCodes as Sheets("sheet1").Range("activities")            'Define the range variable that points to the named range "activities" in sheet 1
outputRow = 1
For Each c in activityCodes
   if c.value = 1 then
      outputRow = outputRow + 1
'  copy the contents of columns A-J on row c.Row,       Worksheets("sheet1").Cells(...).Copy
'  paste the contents into columns A-J on row outputRow in sheet 2      Worksheets("sheet2").Cells(...).Paste
'  copy the contents of row 1 and column c.Column,  Worksheets("sheet1").Cells(...).Copy
'  paste the contents into column J on row outputRow in sheet 2,  Worksheets("sheet2").Cells(...).Paste
   end if
next c
End Sub

Good luck!

 

[Fluff]

How about

Sub Muktar()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, nc As Long
   
   With Sheets("Sheet4")
      Ary = .Range("A1").CurrentRegion.Value2
   End With
   ReDim Nary(1 To UBound(Ary) * 16, 1 To 11)
   
   For r = 2 To UBound(Ary)
      For c = 11 To 26
         If Ary(r, c) = 1 Then
            nr = nr + 1
            For nc = 1 To 10
               Nary(nr, nc) = Ary(r, nc)
            Next nc
            Nary(nr, 11) = Ary(1, c)
         End If
      Next c
   Next r
   With Sheets("Sheet2")
      .Range("A1:J1").Value = Sheets("Sheet4").Range("A1:J1").Value
      .Range("A2").Resize(nr, 11).Value = Nary
   End With
End Sub

 

[FracinDean]

Very creative names by @Fluff !