宏從自動篩選結果只粘貼一個柱子結果

Question

我設法編輯一個自動篩選宏的例子來粘貼我的工作表中的數據。我遇到的問題是我只想粘貼C列的過濾結果，而不是整個範圍。如何做到這一點？謝謝！ 這裏是我的代碼：

Sub Copy_With_AutoFilter1() 

Dim My_Range As Range 
Dim CalcMode As Long 
Dim ViewMode As Long 
Dim FilterCriteria As String 
Dim CCount As Long 
Dim WSNew As Worksheet 
Dim sheetName As String 
Dim rng As Range 
Dim res As Range 

Set My_Range = Worksheets("Data").Range("A1:P" & LastRow(Worksheets("DData"))) 
My_Range.Parent.Select 

If ActiveWorkbook.ProtectStructure = True Or _ 
    My_Range.Parent.ProtectContents = True Then 
    MsgBox "Sorry, not working when the workbook or worksheet is protected", _ 
      vbOKOnly, "Copy to new worksheet" 
    Exit Sub 
End If 

'Change ScreenUpdating, Calculation, EnableEvents, .... 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 
ViewMode = ActiveWindow.View 
ActiveWindow.View = xlNormalView 
ActiveSheet.DisplayPageBreaks = False 

'Firstly, remove the AutoFilter 
My_Range.Parent.AutoFilterMode = False 


My_Range.AutoFilter Field:=14, Criteria1:="=Canada" 
My_Range.AutoFilter Field:=7, Criteria1:="=No" 


'Check if there are not more then 8192 areas (limit of areas that Excel can copy) 
CCount = 0 
On Error Resume Next 
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count 
On Error GoTo 0 
If CCount = 0 Then 
    MsgBox "There are more than 8192 areas:" _ 
     & vbNewLine & "It is not possible to copy the visible data." _ 
     & vbNewLine & "Tip: Sort your data before you use this macro.", _ 
      vbOKOnly, "Copy to worksheet" 
Else 

    'Copy/paste the visible data to the new worksheet 

    My_Range.Parent.AutoFilter.Range.Copy 
    With Sheets("Result").Range("A1") 
     ' Paste:=8 will copy the columnwidth in Excel 2000 and higher 
     ' Remove this line if you use Excel 97 
     .PasteSpecial Paste:=8 
     .PasteSpecial xlPasteValues 
     .PasteSpecial xlPasteFormats 
     Application.CutCopyMode = False 
     .Select 
    End With 
End If 

'Close AutoFilter 
My_Range.Parent.AutoFilterMode = False 

'Restore ScreenUpdating, Calculation, EnableEvents, .... 
My_Range.Parent.Select 
ActiveWindow.View = ViewMode 
If Not WSNew Is Nothing Then WSNew.Select 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = CalcMode 
End With 

End Sub 


Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
         After:=sh.Range("A1"), _ 
         Lookat:=xlPart, _ 
         LookIn:=xlValues, _ 
         SearchOrder:=xlByRows, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Row 
    On Error GoTo 0 
End Function 

Answer 1

複製粘貼在Excel中很容易：

'define a range 
dim rng as range 
set rng=sheets("CopyFrom").Range("C1:C88") 
'copy the content of that range 
rng.copy 
'and paste it: 
Sheets("Result").Range("C1").paste 

所以不是

My_Range.Parent.AutoFilter.Range.Copy 

你會需要像

My_Range.columns(2).copy 
' or 
My_Range.Parent.AutoFilter.Range.column(2).Copy