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

wtom0412

Board Regular
Joined
Jan 3, 2015
Messages
168
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​
NameLine numberUnique Helper Cellscore
Fred11Fred [=B2&A2]100
Fred22Fred101
Fred33Fred102
Fred44Fred103
Fred55Fred104
Fred66Fred105
Mary11Mary106
Mary22Mary107
Mary33Mary108
Mary44Mary109
Mary55Mary110
Mary66Mary111
Mary77Mary112
Mary88Mary113
Mary99Mary114
Andrew11Andrew115
Andrew22Andrew116
Andrew33Andrew117
Julie11Julie118
Julie22Julie119
Julie33Julie120
Julie44Julie121
Julie55Julie122


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 ValueLine Number (Hidden)Unique Helper Cell (Hidden)Score
20011Fred [=B4&$E$1]100 [=IFERROR(VLOOKUP(C4,Score!$C:$D,2,0),"")]
20122Fred [=B5&$E$1]101 [=IFERROR(VLOOKUP(C5,Score!$C:$D,2,0),"")]
20233Fred [=B6&$E$1]102 [=IFERROR(VLOOKUP(C6,Score!$C:$D,2,0),"")]
20344Fred [=B7&$E$1]103 [=IFERROR(VLOOKUP(C7,Score!$C:$D,2,0),"")]
20455Fred [=B8&$E$1]104 [=IFERROR(VLOOKUP(C8,Score!$C:$D,2,0),"")]
20565Fred [=B9&$E$1]105 [=IFERROR(VLOOKUP(C9,Score!$C:$D,2,0),"")]
77Fred [=B10&$E$1]"" [=IFERROR(VLOOKUP(C10,Score!$C:$D,2,0),"")]
88Fred
99Fred
1010Fred
1111Fred
1212Fred
1313Fred
1414Fred
1515Fred
1616Fred
1717Fred
1818Fred
1919Fred
2020Fred
2121Fred
2222Fred
2323Fred
2424Fred
2525Fred
2626Fred
2727Fred
2828Fred
2929Fred
3030Fred

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
 

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

hnsd24_CN

Board Regular
Joined
Oct 13, 2020
Messages
78
Office Version
  1. 2016
Platform
  1. Windows
write in sheet Change
VBA Code:
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
VBA Code:
Public ws1 As Worksheet
Public ws2 As Worksheet
Public scorearr() As String
Public rowarr() As Integer
 

wtom0412

Board Regular
Joined
Jan 3, 2015
Messages
168
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

Board Regular
Joined
Oct 13, 2020
Messages
78
Office Version
  1. 2016
Platform
  1. Windows
test.gif
 

hnsd24_CN

Board Regular
Joined
Oct 13, 2020
Messages
78
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

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

Board Regular
Joined
Jan 3, 2015
Messages
168
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

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

in the following...

Code:
      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

Board Regular
Joined
Oct 13, 2020
Messages
78
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Put code on the Change Sheet,just one click
one more thing:
In your instance worksheet, you used sheet(Score) instead of sheet(RawData)
Excel Formula:
=IFERROR(VLOOKUP(C4,Score!$C:$D,2,0),"")
So I used sheet(Score) in my code,if I get it wrong,you just change
VBA Code:
Set ws1 = Worksheets("Score")
to
VBA Code:
Set ws1 = Worksheets("RawData")
VBA Code:
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
 
Last edited:

hnsd24_CN

Board Regular
Joined
Oct 13, 2020
Messages
78
Office Version
  1. 2016
Platform
  1. Windows
sorry, I made some changes
VBA Code:
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
 
Last edited:

wtom0412

Board Regular
Joined
Jan 3, 2015
Messages
168
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
 

Watch MrExcel Video

Forum statistics

Threads
1,114,193
Messages
5,546,479
Members
410,742
Latest member
WalterSil
Top