Thread: Transferring data from cells to another sheet if criteria is met

Hey guys, this is my first post and I really hope someone will be able to help me. So here is a little background on my project. I am an environmental engineer doing different risk/health assessments on various sites. My excel (2007) file has 4 sheets. The first three are based on increasing health and safety risks uncovered at the sites (i.e green, amber and red).

Each sheet (1,2 and 3) contains 3 columns. A contains abbreviations for a certain risk, B has a description of that risk, and C is for a yes/no checklist if the health and safety risk described in that row applies to that site.

So what I need is that if I type 'y' in a cell from C (on any of the first 3 sheets), the corresponding description in cell B is transferred to Sheet 4.

Does this make sense? Please let me know if you need more detail or what I can do make this work.

Thanks in Advance!

All possible combinations between red, amber and green can be selected. The selected descriptions should start in row 35. It may be easier if on sheet 4 the green, amber and red are in columns A, B and C, but they must begin there, because there is text in the rows above. I sent a new file with the changes made. Will I be able to modify the code to transfer just the abbreviations instead of the descriptions?

Thanks

Hi iamonfire,

I change a bit your worksheets to normalize them (multi rows I replaced with one row with word-wrap; delete column F from Red List [check list was in column G], now 1,2,3 sheet looks the same)

Check if attached file cover your needs - to sheet4 for now only description from columns B is copy in time of selecting in column F.
Whole code is in "ThisWorkbook" code.

Best Regards

whole working code for you
replace previous one with this:

Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
If Target.Rows.Count = 1 And Target.Columns.Count = 1 And Target.Column = 6 Then
    If Target.Row > 15 And Target.Offset(, -4).Value <> "" Then
        If Target.Value = "a" Then
            Target.Value = ""
        Else
            Target.Value = "a"
        End If
        Target.Offset(, 1).Select
        
        updateSheet4 'sh 'run copy from activesheet to sheet4
    End If
End If
End Sub

Sub updateSheet4()
Dim r, rr As Integer 'row index for Checklist and sheet4
rr = 36
Sheet4.Range("A36:A200").Delete shift:=xlUp 'use range which will be bigger then you ever need for write all results in sheet4

Dim sh 'memory holds your source sheets names; you can add here more if you want but make sure that you add here name which exists
sh = Array("Red List", "Amber List", "Green List")

For i = 0 To UBound(sh) 'loop through all sheets mentioned in array
 r = 16 'set start row index
  With Sheet4.Cells(rr, 1)
    .Value = sh(i) 'write sheet name
    .Font.FontStyle = "Bold" 'set font to bold 
    .Font.Size = 14 'set font size
  End With
  rr = rr + 1

    Do Until Sheets(sh(i)).Cells(r, 2).Value = ""
        If Sheets(sh(i)).Cells(r, 6).Value = "a" Then
          Sheets(sh(i)).Range("A" & r).Copy Sheet4.Range("A" & rr) 'copy values from source sheet column A to sheet4 column A
          rr = rr + 1 'increse destination row
        End If
      r = r + 1 'increase source row
    Loop
Next i
End Sub

Best Regards
MaczaQ

But can I have the text in the code so that scrolls down along with the rest of the list? (i.e after Green list)??
I've tried adding a new worksheet and adding it to the Array, then hiding the tab.