Блог

Мне удалось отредактировать пример макроса автофильтра, чтобы вставить данные в мой лист. Проблема в том, что я хочу вставить только отфильтрованные результаты столбца 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" amp; 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:" _
         amp; vbNewLine amp; "It is not possible to copy the visible data." _
         amp; vbNewLine amp; "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
  

Копировать-вставить в 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