Error: "The Action won't work on multiple selections"

[Pineapple_Crazy]

Hey Guys,

Been having some issues with the piece of code below. Basically I am copying over 1 value from a source sheet into another workbook by using the criteria depicted in the code below. However, about 70% of the time I receive the error of "The Action won't work on multiple selections". I am only selecting, copying, and pasting a single value though and cannot figure out why the code fails with this error. The code fails where it is highlighted below and in bigger font. I've done some research and haven't found a great solution. Anyone have a work around for this or experienced something similar? Thanks in advance!

Sub FindingValuesTest()
'Declaring variables
Dim FindRow As Long, findrow2 As Long
Dim find As Range
Dim StrFile As String
Dim StrPath As String
Dim r1 As Long, wb As Workbook
'location of source file
StrPath = "Y:\Finance\BI\Pete\Pete Documents\Misc\"
StrFile = Dir(StrPath & "Vendor*" & "*.xls*")
'msg box to enter vendor ID
myValue = InputBox("Please Enter the Vendor Name", "VENDOR NAME", "REDH001")
'Opens file
Set wb = Workbooks.Open(Filename:=StrPath & StrFile)
wb.Activate
'Finding a match
FindRow = Range("A:A").find(myValue, Range("A1")).Row
r1 = FindRow
Do
    wb.Activate
    On Error Resume Next
    FindRow = Range("A:A").find(what:=myValue, after:=Cells(FindRow, 1)).Row
    findrow2 = Range("H:H").find(what:="Modified:", after:=Range("H" & FindRow)).Row
    Set rgCopy = Range("H" & FindRow + 10 & ":H" & findrow2 + 0).Offset(0, 3).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
   If Not rgCopy Is Nothing Then
  [SIZE=5][B] rgCopy.Copy[/B][/SIZE]
    'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.
    Windows("FinalReport_Vendor.xlsm").Activate
    Sheets("Data").Activate
    ActiveSheet.Range("AC5000").End(xlUp).Offset(1, 0).Select
    'ActiveSheet.Paste
    Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=True, Transpose:=True
   Set rgCopy = Nothing
End If
Loop While FindRow > 1 And FindRow <> r1

End Sub

 

[pgc01]

...I am only selecting, copying, and pasting a single value ...

I don't understand.

Are you not defining rgcopy with several values, not just one?

...
    Set rgCopy = Range("H" & FindRow + 10 & ":H" & findrow2 + 0).Offset(0, 3).SpecialCells(xlCellTypeConstants)

...
  [SIZE=2][B] rgCopy.Copy[/B][/SIZE]
...

Unless FindRow+10 is equal to findrow2, you are defining a range that spans several rows, and the .SpecialCells may result in a multi-are range.

Please clarify.

 

[Pineapple_Crazy]

I don't understand.

Are you not defining rgcopy with several values, not just one?



Unless FindRow+10 is equal to findrow2, you are defining a range that spans several rows, and the .SpecialCells may result in a multi-are range.

Please clarify.

Hey pgc01,

Thanks for the response. It's actually looking for "myValue" (entered in a message box) and "Modified:" in the worksheet then doing an offset to find a particular cell that is copied off of those two values. Essentially, only one cell is copied from this code and not a range. I've tested it to see that it only does indeed copy one cell. The code works fine for the most part, but every now and again it would throw that error. I found a work around for this, shown below. There was no real reason in this case to find both values and then offset. And actually this part of the original code should have been Set rgCopy = Range("A" & FindRow + 10 & ":H" & findrow2 + 0).Offset(0, 3).SpecialCells(xlCellTypeConstants) and not Set rgCopy = Range("H" & FindRow + 10 & ":H" & findrow2 + 0).Offset(0, 3).SpecialCells(xlCellTypeConstants). However, was still sometimes getting that same error.

Thanks!

wb.Activate
'Finding a match
FindRow = Range("A:A").find(what:=myValue).Row
r1 = FindRow
Do
    wb.Activate
    FindRow = Range("A:A").find(what:=myValue, after:=Cells(FindRow, 1)).Row
    Range("A" & FindRow).Offset(0, 10).End(xlDown).End(xlDown).End(xlDown).Copy
 
    'Shifts focus back to macro workbook and pastes data in given worksheet. Puts cursor at bottom of A (5000) and searches up for last data entered.
    Windows("FinalReport_Vendor.xlsm").Activate
    Sheets("Data").Activate
    ActiveSheet.Range("AC5000").End(xlUp).Offset(1, 0).Select
    'ActiveSheet.Paste
    Selection.PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
Loop While FindRow > 1 And FindRow <> r1