Question

我的代码可以复制来自工作表1上的1个单元格位置的选定数据（推荐）＆amp;将其粘贴在表2上的另一个位置（VOC_ASST）。这是代码：

`Sub VOC_ASST()
'Copies names from "Monthly Referals" sheet to "Voc_ Asst" Sheet.
'Prevents duplication of names.
Dim All As Range, R As Range
Dim Data

With Sheets("Referrals")
  'Find all VR
  Set All = FindAll(.Range("M:M"), "VR")
  If All Is Nothing Then
    MsgBox "No VR found."
    Exit Sub
  End If
  'Map to column B
  Set All = Intersect(All.EntireRow, .Range("B:B"))
  'Get unique names
  Data = UniqueItems(All, vbTextCompare)
End With
'Transpose to rows
Data = WorksheetFunction.Transpose(Data)
With Sheets("VOC_ASST")
  'Find last column
  Set R = .Cells(3, .Columns.Count).End(xlToLeft).Offset(, 0)
  'Write the data
  R.Resize(UBound(Data), 1).Value = Data
  End With
 End Sub

Private Function FindAll(ByVal Where As Range, ByVal What, _
Optional ByVal After As Variant, _
Optional ByVal LookIn As XlFindLookIn = xlValues, _
Optional ByVal LookAt As XlLookAt = xlWhole, _
Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
Optional ByVal MatchCase As Boolean = False, _
Optional ByVal SearchFormat As Boolean = False) As Range
'Find all occurrences of What in Where (Windows version)
Dim FirstAddress As String
Dim c As Range
'From FastUnion:
Dim Stack As New Collection
Dim Temp() As Range, Item
Dim i As Long, j As Long

If Where Is Nothing Then Exit Function
If SearchDirection = xlNext And IsMissing(After) Then
  'Set After to the last cell in Where to return the first cell in Where in   
 front if _
    it match What
  Set c = Where.Areas(Where.Areas.Count)
  'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
  'Set After = C.Cells(C.Cells.Count)
  Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
End If

Set c = Where.find(What, After, LookIn, LookAt, SearchOrder, _
  SearchDirection, MatchCase, SearchFormat:=SearchFormat)
If c Is Nothing Then Exit Function

FirstAddress = c.Address
Do
  Stack.Add c
  If SearchFormat Then
    'If you call this function from an UDF and _
      you find only the first cell use this instead
    Set c = Where.find(What, c, LookIn, LookAt, SearchOrder, _
      SearchDirection, MatchCase, SearchFormat:=SearchFormat)
  Else
    If SearchDirection = xlNext Then
      Set c = Where.FindNext(c)
    Else
      Set c = Where.FindPrevious(c)
    End If
  End If
  'Can happen if we have merged cells
  If c Is Nothing Then Exit Do
Loop Until FirstAddress = c.Address
 'Get all cells as fragments
ReDim Temp(0 To Stack.Count - 1)
 i = 0
For Each Item In Stack
  Set Temp(i) = Item
  i = i + 1
Next
'Combine each fragment with the next one
j = 1
Do
  For i = 0 To UBound(Temp) - j Step j * 2
    Set Temp(i) = Union(Temp(i), Temp(i + j))
  Next
  j = j * 2
Loop Until j > UBound(Temp)
'At this point we have all cells in the first fragment
Set FindAll = Temp(0)
End Function

Private Function UniqueItems(ByVal R As Range, _
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare, _
Optional ByRef Count) As Variant
'Return an array with all unique values in R
'  and the number of occurrences in Count
Dim Area As Range, Data
Dim i As Long, j As Long
Dim Dict As Object 'Scripting.Dictionary
Set R = Intersect(R.Parent.UsedRange, R)
If R Is Nothing Then
UniqueItems = Array()
Exit Function
End If
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = Compare
For Each Area In R.Areas
Data = Area
If IsArray(Data) Then
  For i = 1 To UBound(Data)
    For j = 1 To UBound(Data, 2)
      If Not Dict.Exists(Data(i, j)) Then
        Dict.Add Data(i, j), 1
      Else
        Dict(Data(i, j)) = Dict(Data(i, j)) + 1
      End If
    Next
  Next
Else
  If Not Dict.Exists(Data) Then
    Dict.Add Data, 1
  Else
    Dict(Data) = Dict(Data) + 1
  End If
End If
Next
 UniqueItems = Dict.Keys
 Count = Dict.Items
 Dim Msg As String, Ans As Variant

Msg = "Hey!!! Copying complete!! Any Thing Else?"

Ans = MsgBox(Msg, vbYesNo)

Select Case Ans

Case vbYes

    Sheets("Referrals").Select

Case vbNo
`GoTo Quit:
End Select

Quit:         ActiveWorkbook.Close

End Function`

问题是它应该开始在第5行A列中发布，＆amp;它在第3行A列中发布。如果我将其更改为第1行或第2行，则会发布。如果我将其更改为5，则不会发布。有什么建议？我从其他地方得到了帮助，但我不记得这个位置。

Answer 1

确定粘贴位置的代码是

行

Set R = .Cells(3, .Columns.Count).End(xlToLeft).Offset(, 0)

选择第3行中使用的最后一个单元格。因此将其粘贴到第3行。要将其放入第5行A列，请使用

Set R = .Cells(5, 1)

代替。

从一张纸上复制数据＆amp;将它粘贴在第二张纸上的错误位置

1 个答案: