VBA Loop through Range copy paste values on another sheet

[pthomas416]

I am trying to write VBA to look through a range I have titled "Programs" which runs from column BH2:DY39. I am trying to write a macro that will look through each record of 37 project codes and look for a Y in the row. If there is a Y, then I need the macro to copy the project code from coumn H (no included in the "Programs" range currenlty) and copy the header in the table above where the Y is located and paste both side by side on a new sheet. I need it to loop through all the columns looking for Y and doing the same thing, then to start with the next row.

I'm lost on where to start with this, but I'm hoping someone here can help point me in the right direction.

thanks so much!

 

[mumps]

Are the headers in row 1? Can there be more than one "Y" in any one row? If so, how do you want to handle this? Do you want to paste the 2 values in columns A and B of the new sheet?

 

[pthomas416]

Are the headers in row 1? Can there be more than one "Y" in any one row? If so, how do you want to handle this? Do you want to paste the 2 values in columns A and B of the new sheet?

mumps,
Thank you for replying! Yes there are going to be 42 columns that could possibly have a "Y" or a "N". I need for the macro to look through all of the specified columns and for each instance where a "Y" is reflected in that column, it needs to copy what is in column H (not the header but in the same row it is looking in) and then the HEADER of the column where the "Y" was. for "N" or blank just skip. so there will be muliple records for the value in column H that will be copied and pasted to another sheet, and then the program it impacts (value in the header) copied and pasted with it.

 

[mumps]

OK. I have to go out for an appointment so I will send you a response as soon as I get back.

 

[mumps]

The following macro assumes that you have a sheet named "Sheet2" in your workbook. Change the sheet name in the code to suit your needs. Run the macro with your data sheet as the active sheet.

Sub CopyVals()
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim x As Long
    For x = 2 To 39
        Set foundVal = Range("BH" & x & ":DY" & x).Find("Y", LookIn:=xlValues, lookat:=xlWhole)
        If Not foundVal Is Nothing Then
            sAddr = foundVal.Address
            Do
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Range("H" & x)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = Cells(1, foundVal.Column)
                Set foundVal = Range("BH" & x & ":DY" & x).FindNext(foundVal)
            Loop While foundVal.Address <> sAddr
            sAddr = ""
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[pthomas416]

The following macro assumes that you have a sheet named "Sheet2" in your workbook. Change the sheet name in the code to suit your needs. Run the macro with your data sheet as the active sheet.

Sub CopyVals()
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim x As Long
    For x = 2 To 39
        Set foundVal = Range("BH" & x & ":DY" & x).Find("Y", LookIn:=xlValues, lookat:=xlWhole)
        If Not foundVal Is Nothing Then
            sAddr = foundVal.Address
            Do
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Range("H" & x)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = Cells(1, foundVal.Column)
                Set foundVal = Range("BH" & x & ":DY" & x).FindNext(foundVal)
            Loop While foundVal.Address <> sAddr
            sAddr = ""
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

This is fabulous! Thank you so much! What change would I make in the code to have x = Field [ID]? I just want to make sure as the table records grow, that this macro will adjust and caputre all of the projects. This is so helpful! Thank you!

 

[mumps]

I'm not sure what you mean by "to have x = Field [ID]". If you will be adding data to your table and running the macro after each update, the macro won't work as expected the second time you run it. Will you be expanding the 37 project codes so that there are more than 37 rows in your defined range?

 

[pthomas416]

Yes, this table will most likely expand further than 37 rows.

 

[mumps]

This macro assumes that there is no data in column DY below the last project code. In this way, the macro will automatically adjust to any new codes that are added. It will also clear Sheet2 of previous data each time you run the macro and then refresh it with the updated data.

Sub CopyVals()
    Application.ScreenUpdating = False
    Dim bottomDY As Long
    bottomDY = Range("DY" & Rows.Count).End(xlUp).Row
    Dim rng As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim x As Long
    Sheets("Sheet2").UsedRange.ClearContents
    For x = 2 To bottomDY
        Set foundVal = Range("BH" & x & ":DY" & x).Find("Y", LookIn:=xlValues, lookat:=xlWhole)
        If Not foundVal Is Nothing Then
            sAddr = foundVal.Address
            Do
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Range("H" & x)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = Cells(1, foundVal.Column)
                Set foundVal = Range("BH" & x & ":DY" & x).FindNext(foundVal)
            Loop While foundVal.Address <> sAddr
            sAddr = ""
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

 

[pthomas416]

Mumps,

I went to run this macro again and it was only copying down the project code, not the application piece (the part the runs through the columns from BH3:DY3) Do you know why this would be?

This macro assumes that there is no data in column DY below the last project code. In this way, the macro will automatically adjust to any new codes that are added. It will also clear Sheet2 of previous data each time you run the macro and then refresh it with the updated data.

Sub CopyVals()
    Application.ScreenUpdating = False
    Dim bottomDY As Long
    bottomDY = Range("DY" & Rows.Count).End(xlUp).Row
    Dim rng As Range
    Dim foundVal As Range
    Dim sAddr As String
    Dim x As Long
    Sheets("Sheet2").UsedRange.ClearContents
    For x = 2 To bottomDY
        Set foundVal = Range("BH" & x & ":DY" & x).Find("Y", LookIn:=xlValues, lookat:=xlWhole)
        If Not foundVal Is Nothing Then
            sAddr = foundVal.Address
            Do
                Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Range("H" & x)
                Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = Cells(1, foundVal.Column)
                Set foundVal = Range("BH" & x & ":DY" & x).FindNext(foundVal)
            Loop While foundVal.Address <> sAddr
            sAddr = ""
        End If
    Next x
    Application.ScreenUpdating = True
End Sub