Code to Loop through cells and record info

Hi - I am a noobie to programming, and learning as I go.

I have a spreadsheet with 3 cells - G7, G14, and G26.

I need to enter values in these cells, record the results in the spreadsheet, and then move to the next cell.

So for example, Cell G7 can contain Dog, Cat, Bird, each time prompting if there are more values - and if not, moving onto G14, but recording these values in cells A49, A50, A51 and so on.

Cell g14 then records Spot, Puss, Tweety, again recording the values in B49, B50, B51..

I have written code that prompts for all values in G&, but I want to record values in g7, G14, G26 then if more values required, return to G7 again.

Can anybody give me any hints on how to start - this is what I have so far...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, r As Range, res As VbMsgBoxResult
Static myList1(), n1 As Long, myList2(), n2
Set rng = Intersect(Target, Range("g7,g14"))
If rng Is Nothing Then GoTo Exit_Sub
For Each r In rng
If Not IsEmpty(r) Then
If r.Row = 7 Then
ReDim Preserve myList1(n1)
myList1(n1) = r.Value
n1 = n1 + 1
If vbYes <> MsgBox("Any more?", vbYesNo + vbQuestion) Then
Result myList1, Range("a49")
n1 = 0
End If
r.Activate
Else
ReDim Preserve myList2(n2)
myList2(n2) = r.Value
n2 = n2 + 1
If vbYes <> MsgBox("Any more?", vbYesNo + vbQuestion) Then
Result myList2, Range("b49")
n2 = 0
End If
r.Activate
End If
End If
Next
Exit_Sub:
Set rng = Nothing
End Sub

Private Sub Result(myList, rng As Range)
Application.EnableEvents = False
With rng.EntireColumn
.Rows("49:" & Rows.Count).Clear
.Cells(49).Resize(UBound(myList) + 1).Value = _
Application.Transpose(myList)
End With
Application.EnableEvents = True
End Sub
Sign In or Register to comment.

Howdy, Stranger!

It looks like you're new here. If you want to get involved, click one of these buttons!

Categories