Loop through an array on one sheet and loop through another sheet and paste

[wtom0412]

Hello All,

I have been trying for hours to find a solution to my problem.

Earlier, Puertorekinsam helped me a lot, but his solution threw up errors in my sheet that he couldn't replicate (my Worksheet is very complicated so I'm sure it was stuff that I didn't tell him). So I have created a dumbed down version of my Worksheet in an attempt to make this easier to explain.

I have two worksheets: Change and RawData (I have added formulas that I am using into square brackets).

RawData contains all of the data in a long list for 200 people (about 1000+ rows of data). Each person can have up to 30 scores against their name - some have as few as one score, others can have the full 30, and others anything in between.

I use Column B and C in both sheets to provide me with a Unique Helper Cell top assist with VlookUp.

A​	B​	C​	D​
Name	Line number	Unique Helper Cell	score
Fred	1	1Fred [=B2&A2]	100
Fred	2	2Fred	101
Fred	3	3Fred	102
Fred	4	4Fred	103
Fred	5	5Fred	104
Fred	6	6Fred	105
Mary	1	1Mary	106
Mary	2	2Mary	107
Mary	3	3Mary	108
Mary	4	4Mary	109
Mary	5	5Mary	110
Mary	6	6Mary	111
Mary	7	7Mary	112
Mary	8	8Mary	113
Mary	9	9Mary	114
Andrew	1	1Andrew	115
Andrew	2	2Andrew	116
Andrew	3	3Andrew	117
Julie	1	1Julie	118
Julie	2	2Julie	119
Julie	3	3Julie	120
Julie	4	4Julie	121
Julie	5	5Julie	122

Change uses a VlookUp to get the score from RawData Column D and uses a dropdown (name - cell E1) as the reference. I am sure there are much easier ways to pull in the data into this sheet, but it works!!

A​	B​	C​	D​	E​
			Name​	Fred​
Change Value	Line Number (Hidden)	Unique Helper Cell (Hidden)	Score
200	1	1Fred [=B4&$E$1]	100 [=IFERROR(VLOOKUP(C4,Score!$C:$D,2,0),"")]
201	2	2Fred [=B5&$E$1]	101 [=IFERROR(VLOOKUP(C5,Score!$C:$D,2,0),"")]
202	3	3Fred [=B6&$E$1]	102 [=IFERROR(VLOOKUP(C6,Score!$C:$D,2,0),"")]
203	4	4Fred [=B7&$E$1]	103 [=IFERROR(VLOOKUP(C7,Score!$C:$D,2,0),"")]
204	5	5Fred [=B8&$E$1]	104 [=IFERROR(VLOOKUP(C8,Score!$C:$D,2,0),"")]
205	6	5Fred [=B9&$E$1]	105 [=IFERROR(VLOOKUP(C9,Score!$C:$D,2,0),"")]
	7	7Fred [=B10&$E$1]	"" [=IFERROR(VLOOKUP(C10,Score!$C:$D,2,0),"")]
	8	8Fred
	9	9Fred
	10	10Fred
	11	11Fred
	12	12Fred
	13	13Fred
	14	14Fred
	15	15Fred
	16	16Fred
	17	17Fred
	18	18Fred
	19	19Fred
	20	20Fred
	21	21Fred
	22	22Fred
	23	23Fred
	24	24Fred
	25	25Fred
	26	26Fred
	27	27Fred
	28	28Fred
	29	29Fred
	30	30Fred

Using Fred as the reference, the Vlookup brings in six scores, so what I would like to do is enter new values in to A4:A9 of this sheet, press a button, and paste those values from Change A4:A9 into in RawData D2:D7 (using the Unique Helper Cell in Column C on both sheets).

Similarly, if I choose Andrew, only three scores get pulled in so I change the values in A4:A6, press the button and paste the values in RawData D17:D19.

I hope all of this makes sense!!? I have found some code on the net, and Puertorekinsam added a lot to it, but it relates to my original worksheet, and as previously mentioned it throws error messages, so I'm not sure there is much point pasting it here? Happy to amend it to relate to this sheet and post it if that would be useful?

I would really appreciate any assistance you can give.

Cheers, Toby

 

[hnsd24_CN]

write in sheet Change

Private Sub CommandButton1_Click()
   Dim i As Integer
   Dim r As Integer
   Dim n As Integer
   Dim s As Integer
   n = 1
   Set ws1 = Worksheets("RawData")
   Set ws2 = Worksheets("Change")
   r = ws1.Range("A65536").End(xlUp).Row
   s = ws2.Range("D65536").End(xlUp).Row
   If s > 3 Then
      ws2.Range("A4:D" & s).ClearContents
   End If
   ReDim scorearr(1 To 30)
   ReDim rowarr(1 To 30)
   For i = 3 To r
       If ws1.Range("A" & i) = ws2.Range("E1") Then
          scorearr(n) = ws1.Range("D" & i)
          rowarr(n) = i
          n = n + 1
       End If
   Next
   If n > 1 Then
      ws2.Range("D4:D" & n + 2) = Application.Transpose(scorearr)
   Else
      MsgBox "No data was found"
   End If
End Sub

Private Sub CommandButton2_Click()
   Dim i As Integer
   Dim r As Integer
   Dim n As Integer
   Dim s As Integer
   Dim rng As Range
   Set ws1 = Worksheets("RawData")
   Set ws2 = Worksheets("Change")
   r = ws2.Range("D65536").End(xlUp).Row
   s = ws2.Range("A65536").End(xlUp).Row
   ReDim scorearr(1 To 30)
   If s > 3 And r > 3 Then
      For i = 4 To r
          If Not rng Is Nothing Then
            Set rng = Application.Union(rng, ws1.Range("D" & rowarr(i - 3)))
          Else
            Set rng = ws1.Range("D" & rowarr(i - 3))
          End If
      Next
   For i = 4 To r
       If ws2.Range("A" & i) <> "" Then
          scorearr(i - 3) = ws2.Range("A" & i)
       Else
          scorearr(i - 3) = ws2.Range("D" & i)
       End If
   Next
   rng = Application.Transpose(scorearr)
   Else
      MsgBox "No data was selected"
   End If
End Sub

write in module

Public ws1 As Worksheet
Public ws2 As Worksheet
Public scorearr() As String
Public rowarr() As Integer

 

[wtom0412]

Hi,

Thank you so much for your reply.

I am sorry, but I'm a little confused as to why there is two Subs?

Do I put them both on the Change Sheet?

Cheers, Toby

 

[hnsd24_CN]

 

[hnsd24_CN]

CommandButton1(sub1) :copy scores from sheet RawData to sheet Change where name=E1
CommandButton2(sub2) :copy scores from sheet Change to sheet RawData where scores had changed

 

[wtom0412]

Ah, thank you, I get it.

So my sheet already pulls in the data from RawData, so I don't need the first click, but if I run sub2 only, I get a "Run-time error '9': Subscript out of range" in this line

Set rng = ws1.Range("D" & rowarr(i - 3))

in the following...

      For i = 4 To r
          If Not rng Is Nothing Then
            Set rng = Application.Union(rng, ws1.Range("D" & rowarr(i - 3)))
          Else
            Set rng = ws1.Range("D" & rowarr(i - 3))
          End If
      Next

Is that because it is tied into Sub1?

 

[hnsd24_CN]

Put code on the Change Sheet,just one click
one more thing:
In your instance worksheet, you used sheet(Score) instead of sheet(RawData)

=IFERROR(VLOOKUP(C4,Score!$C:$D,2,0),"")

So I used sheet(Score) in my code,if I get it wrong,you just change

Set ws1 = Worksheets("Score")

to

Set ws1 = Worksheets("RawData")

Private Sub CommandButton1_Click()
   Dim ws1 As Worksheet
   Dim ws2 As Worksheet
   Dim i As Integer
   Dim n As Integer
   Dim r As Integer
   Dim s As Integer
   Dim rng As Range
   Dim arr() As Long
   Set ws1 = Worksheets("Score")
   Set ws2 = Worksheets("Change")
   r = ws2.Range("A65536").End(xlUp).Row
   s = ws1.Range("C65536").End(xlUp).Row
   If r < 4 Then
      MsgBox "No score was changed"
   Else
      ReDim arr(1 To Application.CountA(ws2.Range("A4:A" & r)))
      For i = 4 To r
          For n = 3 To s
              If ws2.Range("C" & i) = ws1.Range("C" & n) Then
                 If Not rng Is Nothing Then
                    Set rng = Application.Union(rng, ws1.Range("D" & n))
                 Else
                    Set rng = ws1.Range("D" & n)
                 End If
              End If
          Next
          If ws2.Range("A" & i) <> "" Then
             arr(i - 3) = ws2.Range("A" & i)
          Else
             arr(i - 3) = ws2.Range("D" & i)
          End If
      Next
      rng = Application.Transpose(arr)
      MsgBox Application.CountA(ws2.Range("A4:A" & r)) & " scores was changed"
   End If
End Sub

 

[hnsd24_CN]

sorry, I made some changes

Private Sub CommandButton1_Click()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Integer
    Dim n As Integer
    Dim t As Integer
    Dim r As Integer
    Dim s As Integer
    Dim rng As Range
    Dim arr() As Long
    Set ws1 = Worksheets("Score")
    Set ws2 = Worksheets("Change")
    r = ws2.Range("A65536").End(xlUp).Row
    s = ws1.Range("C65536").End(xlUp).Row
    t = 1
    If r < 4 Then
        MsgBox "No score was changed"
    Else
        ReDim arr(1 To Application.CountA(ws2.Range("A4:A" & r)))
        For i = 4 To r
            If ws2.Range("A" & i) <> "" Then
                For n = 3 To s
                    If ws2.Range("C" & i) = ws1.Range("C" & n) Then
                        If Not rng Is Nothing Then
                            Set rng = Application.Union(rng, ws1.Range("D" & n))
                        Else
                            Set rng = ws1.Range("D" & n)
                        End If
                    End If
                Next
                arr(t) = ws2.Range("A" & i)
                t = t + 1
            End If
        Next
        rng = Application.Transpose(arr)
        MsgBox Application.CountA(ws2.Range("A4:A" & r)) & " scores was changed"
    End If
End Sub

 

[wtom0412]

Hello, firstly, I can not thank you enough for your patience, I really appreciate your time and expertise very much.

Secondly, you are correct, I did change the name of the TAB, I am so sorry that caused issues!!

This works perfectly except it pastes the data one cell down on the Change TAB in Column D for the first name only? The other names work perfectly.

If you don't mind, can I upload my workbook for you to see (if so, how do I do that)?

Cheers, Toby

 

[hnsd24_CN]

I don't know if this violates the rules of the forum
email:hnsd24@163.com