时间戳

首页 > 解决方案 > VBA：任何想法如何记住最初选择的单元格以在代码之后将选择复制到它

excel - VBA：任何想法如何记住最初选择的单元格以在代码之后将选择复制到它

问题描述

嗨，我需要一些帮助。我想选择单元格列并仅提取唯一值并将所有结果缩小到 1 列。代码工作正常，除了我希望将其粘贴到我选择的原始单元格的部分。我试过设置 cell = activecell。但是当我在最后的所有代码都说“范围类的运行时错误 1004 剪切方法失败”之后返回它时，我不断收到错误。谢谢我真的很感激任何帮助。

Sub Super_PasteInto1Col()

'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+m
'

Dim i As Integer
Dim icolumns As Long
Dim columns As Long
Dim rselection As Range
Dim EntireColumn As Range
Dim cell As Range

Set cell = ActiveCell
Application.Goto ActiveCell.EntireColumn.End(xlUp)
Selection.PasteSpecial Paste:=xlPasteValues

Set rselection = Selection
For i = 1 To rselection.columns.Count
Selection.columns(i).RemoveDuplicates columns:=1,   Header:=xlGuess
Selection.columns(i).SortSpecial (xlPinYin)
Next i


icolumns = rselection.columns.Count - 1
For i = 1 To icolumns
Application.Goto rselection.columns(i + 1).End(xlUp)
Set EntireColumn = Selection.EntireColumn

If Application.WorksheetFunction.CountA(EntireColumn) = 1 Then

    If Application.WorksheetFunction.CountA(rselection.columns(1)) = 1 Then
    Selection.Cut rselection.columns(1).End(xlUp).Offset(1, 0)
    
    Else
    Selection.Cut rselection.columns(1).End(xlDown).Offset(1, 0)
    End If

ElseIf Application.WorksheetFunction.CountA(EntireColumn) = 0 Then
Application.Goto Selection


Else
Application.Goto Range(Selection, Selection.End(xlDown))

    If Application.WorksheetFunction.CountA(rselection.columns(1)) = 1 Then
    Selection.Cut rselection.columns(1).End(xlUp).Offset(1, 0)
    
    Else
    Selection.Cut rselection.columns(1).End(xlDown).Offset(1, 0)
    
    End If
End If

Next i


Application.Goto rselection.columns(1).EntireColumn
Selection.RemoveDuplicates columns:=1, Header:=xlNo
Selection.SortSpecial (xlPinYin)
Application.Goto Selection.End(xlUp)
Application.Goto Range(Selection, Selection.End(xlDown))
Selection.Cut cell


Exit Sub



End Sub

标签： excelvbacopycell

解决方案

很难说出你的意图，但以下是我最好的解释。请尝试一下。

Option Explicit

Sub Super_PasteInto1Col()
    ' 153
    ' Keyboard Shortcut: Ctrl+m

    ' TgtClm is the column where the results are deposited
    Const TgtClm        As Long = 18        ' change to suit
    
    Dim SelRng          As Range            ' range selected by the user
    Dim Clm             As Long             ' first column of SelRng
    Dim C               As Long             ' loop counter: Columns
    Dim Rt              As Long             ' target row
    
    Set SelRng = Selection
    Clm = SelRng.Column
    
    Application.ScreenUpdating = False
    With Columns(Clm)
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With

    For C = 0 To (SelRng.Columns.Count - 1)
        ' start the range in row 2 (leave headers untouched)
        With Range(Cells(2, Clm + C), Cells(Rows.Count, Clm + C).End(xlUp))
            ' this range will start in row 1 if the column is otherwise blank
            If .Row > 1 Then
                .RemoveDuplicates Columns:=1, Header:=xlNo
                .SortSpecial (xlPinYin)
                
                If WorksheetFunction.CountA(Range(.Address)) Then
                    .Cut Cells(Rows.Count, TgtClm).End(xlUp).Offset(1)
                End If
            End If
            Columns(Clm + C).ClearContents
        End With
    Next C

    With Application
        .CutCopyMode = False
        .ScreenUpdating = False
    End With
End Sub

在我的测试中，我为第 1 行中的列添加了标题。我选择了其中的一些标题。第一个具有特殊意义，因为该列中的公式将被它们生成的值替换。之后，对选择的每一列进行排序，删除重复项后，将剩余部分（如果有）粘贴到第 18 列（在代码顶部更改）。该列被清除。

我不明白你为什么要回到原来的选择。然而，Selection对象在一开始就被记录下来并且从未改变过。因此，它适用于您的任何想法。

推荐阅读