Get other cells value

Hello,

I am stuck in a formula and I cannot solve it. Please I need help.
I am making a survey on excel, and I need the result for a whole month to be posted for all people. Here where I am at:

1- First I have 6 choices to be chosen from in sheet 1 and I got the result to Sheet 2 after pressing a button. Please see picture 1 through this dropbox link.



2- The YELLOW part shown in the picture 2 is the values got from sheet 1.
Every time the YELLOW part is updated, I need the GREEN part to be auto updated and keep adding down the row for the whole month. Please see picture 2.



I inserted the following code in VBA --> sheet 2:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim goout As Boolean

goout = False
xrow = 1
Set KeyCells = Range("A1:F1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
xcolumn = Range(Target.Address).Column
Do
If Cells(xrow, xcolumn + 10).Value = "" Then
Cells(xrow, xcolumn + 10).Value = Cells(1, xcolumn).Value
goout = True
Else
xrow = xrow + 1
End If
Loop Until goout = True
End If
End Sub

If I update the YELLOW part manually, it will work fine and the GREEN part will auto update.
If I assign the code to an APPLY BUTTON in Sheet 1, the YELLOW part update but the GREEN part do not.

Thank you so much again for your help and time.