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
 
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.
 
Upvote 0

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Click here to download you file. Click the "Transfer" button.
 
Upvote 0
Still getting the same error :(
1602488505388.png


1602488543251.png
 
Upvote 0
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?
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Brilliant thank you! That has done the trick after changing the formatting from currency to number :)
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,236
Members
448,555
Latest member
RobertJones1986

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