VBA: Issue with find, copying & pasting across two worksheets

[blonde]

Hello,

I have a problem with some find, copy and paste coding. On a userform, there is a listbox for the academic year (acad_year) and a textbox for the unique record id (id) which supplies the two variables for this part of the coding. Both of these are working correctly and storing the correct values. The coding looks for these two values in a list in sheet ws, then finds the corresponding id and acad_year in the list in sheet ws2. It then copies and pastes ranges from the relevant row (row i) from ws2 into ws (row i).

The issue is that the coding is not finding the correct acad_year. Where an id has two records in ws2, a 17/18 record and a 18/19 record, it is not finding, copying and pasting the 18/19 record. It is pasting the first record it finds for id in ws2 which is the 17/18 one. (I checked this by switching the records round.)

I think the error may be somewhere on this line, but I don't know how to rectify it. (Range E is the column containing the id in ws2.)

Set pop_fin = ws2.Range("E7:E1000").Find(ws.Range("F" & i).Value, , , xlWhole, , , False, , False)

I would be very grateful for any help on this. The relevant parts of my code are below:

Public Sub Pop_Stu_list()

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim pop_fin As Range
Dim lItem As Long
Dim acad_year As String
Dim lItem2 As Long
Dim faculty As String
Dim id As String

Set ws = ThisWorkbook.Sheets("student list")
Set ws2 = ThisWorkbook.Sheets("QLS Download")

For lItem = 0 To UserForm3.ListBox1.ListCount - 1
        If UserForm3.ListBox1.Selected(lItem) Then
            acad_year = UserForm3.ListBox1.List(lItem)
        End If
    Next lItem
    
For lItem2 = 0 To UserForm3.ListBox2.ListCount - 1
        If UserForm3.ListBox2.Selected(lItem2) Then
            faculty = UserForm3.ListBox2.List(lItem2)
        End If
    Next lItem2
    
id = UserForm3.TextBox1.Value
    
Finalrow = Sheets("student list").Range("A902").End(xlUp).Row
Finalrow2 = Sheets("QLS Download").Range("E902").End(xlUp).Row

Application.ScreenUpdating = False

If id <> "" Then

    With ws    
    For i = 7 To Finalrow
    
    If .Cells(i, 9).Value = acad_year And _
       .Cells(i, 6).Value = id Then
    
    Set pop_fin = ws2.Range("E7:E1000").Find(ws.Range("F" & i).Value, , , xlWhole, , , False, , False)
    
    pop_fin.Offset(, -4).Resize(, 4).Copy
    ws.Range("B" & i).PasteSpecial xlPasteValues
    pop_fin.Offset(, 5).Resize(, 1).Copy
    ws.Range("H" & i).PasteSpecial xlPasteValues
    pop_fin.Offset(, 7).Resize(, 3).Copy
    ws.Range("J" & i).PasteSpecial xlPasteValues
            
    End If       
    Next i   
End With

'further coding not included ...

 

[Dryver14]

dim cell as range at top of sub

 

[blonde]

I set dim Cell as Range but got the same run time error '1004' as before. I tried changing the code line back to:

ws2.Cell("E7:E1000").Select

and now have the message: 'Compile error: Method or data member not found' on the .Cell part of this line.

 

[Dryver14]

We seem to be doing 2 things at once. Lose the with, end with

try this

For i = 7 To Finalrow
    If Cells(i, 9).Value = acad_year Then
    
    ws2.Range("E7:E1000").Select
        For Each Cell In Selection
            If Cell.Value = ws.Cells(i, 6).Value Then
                If Cell.Offset(, 6).Value = acad_year Then
                    Cell.Offset(, -4).Resize(, 4).Copy
                    ws.Range("B" & i).PasteSpecial xlPasteValues
                    Cell.Offset(, 5).Resize(, 1).Copy
                    ws.Range("H" & i).PasteSpecial xlPasteValues
                    Cell.Offset(, 7).Resize(, 3).Copy
                    ws.Range("J" & i).PasteSpecial xlPasteValues
                End If
            End If
        
        Next Cell
        
    End If
        
    Next i

 

[MARK858]

Thank you, I've tried that but got a different run time error '1004 - select method of rnage class failed'.

Personally I would just remove the Select as you can only Select on the active sheet i.e.

ws2.Range("E7:E1000").Select
        For Each Cell In Selection

becomes

For Each Cell In ws2.Range("E7:E1000")

but then I would probably loop the find i.e. replace this in the original code

    Set pop_fin = ws2.Range("E7:E1000").Find(ws.Range("F" & i).Value, , , xlWhole, , , False, , False)
    
    pop_fin.Offset(, -4).Resize(, 4).Copy
    ws.Range("B" & i).PasteSpecial xlPasteValues
    pop_fin.Offset(, 5).Resize(, 1).Copy
    ws.Range("H" & i).PasteSpecial xlPasteValues
    pop_fin.Offset(, 7).Resize(, 3).Copy
    ws.Range("J" & i).PasteSpecial xlPasteValues

with the code below(untested)

Dim pop_fin As Range, fAddr As String
    
    'Rest of code

    With ws2.Range("E7:E1000")

        Set pop_fin = .Find(ws.Range("F" & i).Value, , , xlWhole, , , False, , False)

        If Not pop_fin Is Nothing Then
            fAddr = pop_fin.Address
            Do
                If Not pop_fin Is Nothing Then
                    pop_fin.Offset(, -4).Resize(, 4).Copy
                    ws.Range("B" & i).PasteSpecial xlPasteValues
                    pop_fin.Offset(, 5).Resize(, 1).Copy
                    ws.Range("H" & i).PasteSpecial xlPasteValues
                    pop_fin.Offset(, 7).Resize(, 3).Copy
                    ws.Range("J" & i).PasteSpecial xlPasteValues
                End If

                Set pop_fin = .FindNext(pop_fin)

                If pop_fin Is Nothing Then
                    Exit Do
                End If

                If pop_fin.Address = fAddr Then
                    Exit Do
                End If

            Loop
        End If
    End With

Please note that you will have to change E7 to E6 if E7 isn't a header or change the After criteria to Range("E1000") in the Find.

 

[Dryver14]

Thanks for jumping in Mark,

I was starting to confuse myself

 

[blonde]

I have now got it working! I used your line that replaced the select statement, but I will also experiment using the loop you provided. Thank you both very much for your all your time and help on this, I really appreciate it.

There is just one new bug that seems to have appeared out of this. I'm sorry to be a pain. The values pasted into ws do not show up until you refresh the screen (eg. moving from one sheet and back again, or scrolling up). I haven't encountered this before. Do you know how I can stop this so that the data populates immediately in front of you?

 

[blonde]

I now seem to have resolved the bug with the screen data updating, not sure quite how. Thanks again.

 

[MARK858]

I now seem to have resolved the bug with the screen data updating, not sure quite how. Thanks again.

Your welcome, the Findnext loop should be faster if you have large sets of data (currently yours isn't large) as long as I haven't made any typos.