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
 

hyd1956

New Member
Joined
Jun 26, 2020
Messages
40
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Okay thanks, I've done that and I've also deleted column AA to ensure it was clear too but I'm still getting the same error.
 

Some videos you may like

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

hyd1956

New Member
Joined
Jun 26, 2020
Messages
40
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Still getting the same error :(
1602488505388.png


1602488543251.png
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
I cannot reproduce the error. The macro in the last file I attached is working properly for me. Are you getting the error in the file I attached in Post #12 or are you using the macro in a different file?
 

hyd1956

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

ADVERTISEMENT

Yeah I'm getting the error in the file you attached
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
I have no idea why it is not working for you. I am using Excel 2010 so I thought that compatibility with your version of Excel might be the problem. However, I tested the macro on my wife's laptop that has Office 365 and it worked properly on that machine as well. :confused: When you get the error, hover the mouse over "fnd" in the line of code above the highlighted line. What is displayed?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745

ADVERTISEMENT

I just thought of something. The problem may be caused by the "£" sign. Try this version:
VBA Code:
Private Sub CommandButton2_Click()
    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 = ThisWorkbook.Worksheets("Tracker")
    Set duplicatesheet = ThisWorkbook.Worksheets("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("£" & 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("£" & 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
Thanks for the help, I'm still getting the same error with the new code. fnd = nothing, dvaluetosearch1 = 25, xlvalues =4163, xlwhole = 1 is displayed before the error
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,745
If fnd = nothing, that means that the value £25 is not being found in column H of Tracker when it is actually there. I believe the cause might be how Excel interprets the currency symbol. The only real way to find out if that is the cause, is to format the values in column H of Tracker as 'Number' instead of 'Currency' so that the £ symbol is removed and try this revised version of the macro in the file I uploaded:
VBA Code:
Private Sub CommandButton2_Click()
    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 = ThisWorkbook.Worksheets("Tracker")
    Set duplicatesheet = ThisWorkbook.Worksheets("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(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(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
Brilliant thank you! That has done the trick after changing the formatting from currency to number :)
 

Watch MrExcel Video

Forum statistics

Threads
1,114,479
Messages
5,548,276
Members
410,825
Latest member
Dave12
Top