VBA code for transferring between two sheets based on conditional criteria

hyd1956

New Member
Joined
Jun 26, 2020
Messages
49
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi

Could you help with the following VBA code I'm stuck on. I am trying to do the following:

When column K (sheet 2) equals "Y" I want to transfer the additional information held in other columns from that row to another sheet. The value in V14 (sheet 2) needs to match the value in column H (sheet 1) and the value in column J (sheet1) must be "Available"

The code I have so far is:

Private Sub duplicatefindertransfer()

Dim duplicatesheet As Worksheet
Dim trackersheet As Worksheet

Set trackersheet = ThisWorkbook.Worksheets("Tracker")
Set duplicatesheet = ThisWorkbook.Worksheets("Duplicate Finder")

lastRowLookup = duplicatesheet.Cells(Rows.Count, "A").End(xlUp).Row
lastRowUpdate = trackersheet.Cells(Rows.Count, "I").End(xlUp).Row

For i = 1 To lastRowUpdate
valueToSearch1 = trackersheet.Cells(i, 10)
Valuetosearch2 = trackersheet.Cells(i, 8)
For t = 1 To lastRowLookup
If duplicatesheet.Cells(t, 11) = "Y" And duplicatesheet.Range("V14").Value = valueToSearch1 And "Available" = Valuetosearch2 Then
trackersheet.Cells(i, 10) = duplicatesheet.Cells(t, 14)
trackersheet.Cells(i, 11) = duplicatesheet.Cells(t, 1)
trackersheet.Cells(i, 12) = duplicatesheet.Cells(t, 2)
trackersheet.Cells(i, 14) = duplicatesheet.Cells(t, 15)
trackersheet.Cells(i, 15) = duplicatesheet.Cells(t, 16)
trackersheet.Cells(i, 20) = duplicatesheet.Cells(t, 17)
trackersheet.Cells(i, 21) = duplicatesheet.Cells(t, 18)
trackersheet.Cells(i, 22) = duplicatesheet.Cells(t, 19)
trackersheet.Cells(i, 41) = duplicatesheet.Cells(t, 20)
Exit For
End If
Next t
Next i
MsgBox ("Complete")
End sub
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your two sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).
 
Upvote 0
Thank you for the file. Unfortunately, it doesn't have very much data in both sheets. Could you upload a revised file which has 10 or 12 lines of data in each sheet and manually insert the expected results in the Tracker sheet based on the data in the Duplicate Finder sheet?
 
Upvote 0
Try:
VBA Code:
Private Sub duplicatefindertransfer3()
    Application.ScreenUpdating = False
    Dim duplicatesheet As Worksheet, trackersheet As Worksheet, DvalueToSearch1 As Range
    Dim bottomJ As Long, rng As Range, fnd As Range, sAddr As String
    Set trackersheet = Sheets("Tracker")
    Set duplicatesheet = Sheets("Duplicate Finder")
    Set DvalueToSearch1 = duplicatesheet.Range("W14")
    bottomJ = trackersheet.Columns("J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lastRowLookup = duplicatesheet.Cells(Rows.Count, "A").End(xlUp).Row
    lastRowUpdate = trackersheet.Cells(Rows.Count, "I").End(xlUp).Row
    With duplicatesheet
        .Range("A1:T" & lastRowUpdate).AutoFilter Field:=12, Criteria1:="Y"
        For Each rng In .Range("A2:A" & lastRowUpdate).SpecialCells(xlCellTypeVisible)
            Set fnd = trackersheet.Range("H:H").Find(Chr(163) & DvalueToSearch1, LookIn:=xlValues, lookat:=xlWhole)
            If fnd.Row >= .Range("AA1").Value Then
                If Not fnd Is Nothing Then
                    sAddr = fnd.Address
                    Do
                        If fnd.Offset(, 2) = "Available" Then
                            fnd.Offset(, 3).Resize(, 2).Value = rng.Resize(, 2).Value
                            fnd.Offset(, 7) = rng.Offset(, 16)
                            fnd.Offset(, 12).Resize(, 3).Value = rng.Offset(, 17).Resize(, 3).Value
                            Exit Do
                        End If
                        Set fnd = trackersheet.Range("H:H").FindNext(fnd)
                    Loop While fnd.Address <> sAddr
                    sAddr = ""
                End If
                .Range("AA1") = fnd.Row
            Else
                Set fnd = trackersheet.Range("H" & .Range("AA1") & ":H" & lastRowUpdate).Find(Chr(163) & DvalueToSearch1, LookIn:=xlValues, lookat:=xlWhole)
                If Not fnd Is Nothing Then
                    sAddr = fnd.Address
                    Do
                        If fnd.Offset(, 2) = "Available" Then
                            fnd.Offset(, 3).Resize(, 2).Value = rng.Resize(, 2).Value
                            fnd.Offset(, 7) = rng.Offset(, 16)
                            fnd.Offset(, 12).Resize(, 3).Value = rng.Offset(, 17).Resize(, 3).Value
                            Exit Do
                        End If
                        Set fnd = trackersheet.Range("H:H").FindNext(fnd)
                    Loop While fnd.Address <> sAddr
                    sAddr = ""
                End If
                If fnd.Row = bottomJ Then
                    .Range("A1").AutoFilter
                    .Range("AA1") = ClearContents
                    MsgBox ("Complete")
                    Exit Sub
                End If
                .Range("AA1") = fnd.Row
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thanks for looking into this. I tried but it's not working for me, I get run time error 91 on line: If fnd.Row >= .Range("AA1").Value Then
 
Upvote 0
I tested the macro on the file you posted and it worked properly. Are you using the macro on a different file? if so, upload a copy of the file that is generating the error.
 
Upvote 0
I'm not sure why it's not working for me then, I've tried it using the same file - the file with the error is here Transfer test 2
 
Upvote 0
Delete row 18 with the explanatory comments in the Tracker worksheet. The word "Available" in the range J11:J17 has a trailing space. Remove the trailing space in each cell. Try the macro again.
 
Upvote 0

Forum statistics

Threads
1,213,497
Messages
6,113,999
Members
448,541
Latest member
iparraguirre89

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top