VBA code for transferring between two sheets based on conditional criteria

hyd1956

New Member
Joined
Jun 26, 2020
Messages
40
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
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
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).
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
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?
 

hyd1956

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

ADVERTISEMENT

No problem, I've tried to demonstrate the results I'm trying to get and uploaded a new version here: Transfer test sheet

Thanks for the help
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
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
 

hyd1956

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

ADVERTISEMENT

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
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
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.
 

hyd1956

New Member
Joined
Jun 26, 2020
Messages
40
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,472
Messages
5,548,241
Members
410,824
Latest member
Bobmn4
Top