Question

我正在写一个非常简单的代码来将数据从一个工作簿移动到另一个工作簿。我试图避免使用选择和复制粘贴，因为它被广泛认为不是最佳的。好的，挑战被接受了。我已经掌握了所写的所有内容，而且我突然意识到 - 我不知道如何将一系列过滤数据定义为范围，忽略了过滤掉的部分。我已经做了一些搜索，但我并不完全在那里。目前的代码如下：

Sub CSReport()


Dim CabReport As Workbook
Dim ExCashArchive As Workbook

Dim CABReconFilePath As String

Dim ExCashPath As String


Dim HoldingsTabName As String
Dim IMSHoldingsTabName As String

Dim HoldingsTab As Worksheet
Dim IMSHoldingsTab As Worksheet


Dim LastRowHoldings As Integer
Dim LastRowIMSHoldings As Integer


Dim RngHoldings As Range
Dim RngIMS As Range


Dim dt As Date

        dt = Range("Today")
         'Today is a named range with the date, just incase I need to be manually changing it

        CABReconFilePath = Range("CABReconFilePath")
               ExCashPath = Range("ExcessCashArchiveFilePath")
        'What are the files we care about


        HoldingsTabName = Range("HoldingTieOutTabName")
        IMSHoldingsTabName = Range("IMSHoldingsTabName")
        'What are the tab names we care about



         Workbooks.Open Filename:=CABReconFilePath
         Set CabReport = ActiveWorkbook



          Workbooks.Open Filename:=ExCashPath
          Set ExCashArchive = ActiveWorkbook
          'Opening and defining the workbooks we're dealing with



          HoldingsTab = ExCashArchive.Sheets(HoldingsTabName)
          IMSHoldingsTab = ExCashArchive.Sheets(IMSHoldingsTabName)
          'Defining the tabs

          LastRowHoldings = HoldingsTab.Range("A" & Rows.Count).End(xlUp).Row
          LastRowIMSHoldings = IMSHoldingsTab.Range("A" & Rows.Count).End(xlUp).Row
        'Defining the edges of the data
    'Filter goes here
          RngHoldings = HoldingsTab.Range("A3:K" & LastRowHoldings)
          RngIMS = IMSHoldingsTab.Range("A3:P" & LastRowIMSHoldings)
          'Or maybe it goes here?



    CABReconFilePath.Sheets("Holdings_TieOut").Range("A3").Resize(CopyFrom.Rows.Count).Value = RngHoldings.Value
    CABReconFilePath.Sheets("IMS_Holdings").Range("A3").Resize(CopyFrom.Rows.Count).Value = RngIMS.Value
'Getting the values in

    CABReconFilePath.Sheets("Recon Summary").Range("B1").Value = Text(dt, "MM/DD/YYYY")
'And setting the date manually, just incase we're running prior/future reports



ExCashArchive.Close savechanges:=False
CabReport.SaveAs Filename = CABReconFilePath & Text(dt, "MM.DD.YY")
CabReport.Close



End Sub

现在，我之前所做的是相当笨拙的事情，如：

 Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$W$71").AutoFilter Field:=1, Criteria1:="=*1470*", Operator:=xlFilterValues
    Selection.Copy
  CABReconFilePath.Sheets("CS").Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Application.CutCopyMode = False

这是我迄今为止的方法＆＃34;过滤数据，复制数据，将其粘贴到其他地方＆＃34; - 但是我正在努力学习更好的编程方法，而且我一直听到＆＃34;不要使用select＆＃34;和＆＃34;尽量避免复制粘贴 - 将内容移动到范围内并使用它代替！＆＃34;。但是我在这一点上陷入困境。

编辑：.SpecialCells（xlCellTypeVisible）是我需要添加的限定符。

Answer 1

    Sub CopyFilterRange()
        Dim i As Long
        Dim j As Long
        Dim lRow As Long
        Dim cnt As Long
        Dim UB1 As Long
        Dim UB2 As Long
        Dim rng1 As Range
        Dim rng2 As Range
        Dim arr1() As Variant
        Dim arr2() As Variant
        Dim WS1 As Worksheet
        Dim WS2 As Worksheet

        Set WS1 = ThisWorkbook.Sheets("Sheet1")
        Set WS2 = ThisWorkbook.Sheets("Sheet2") 'this can be a different sheet in a different workbook

        'Find last row in column A
        With WS1
            lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        End With

        'Define range
        Set rng1 = WS1.Range("A1:A" & lRow)

        'Define array out of range
        arr1 = rng1

        'Redim array 2 rows based on the columns of array 1
        'We will define it with one column and rows equal to the same number of columns in array 1
        'The reason is that in arrays only the last index can be flexible and the other indices should stay fixed
        UB1 = UBound(arr1, 1)
        UB2 = UBound(arr1, 2)
        ReDim arr2(1 To UB2, 1 To 1)

        'Loop throug arr1 and filter
        cnt = 0
        For i = 1 To UB1
            For j = 1 To UB2
                If arr1(i, j) = "A" Or arr1(i, j) = "B" Then
                    cnt = cnt + 1
                    ReDim Preserve arr2(1 To UB2, 1 To cnt) 'here we can add one column to array while preserving the data
                    bResizeArray = False 'resizing array should happen only once in the inner loop
                    arr2(j, cnt) = arr1(i, j)
                End If
            Next j
        Next i

        'Transpose arr2
        arr2 = TransposeArray(arr2)

        'Paste arr2 value in the destination range
        'Define the size of destination range
        Set rng2 = WS2.Range("A1")
        Set rng2 = rng2.Resize(UBound(arr2, 1), UBound(arr2, 2))
        rng2.Value = arr2
    End Sub

    Public Function TransposeArray(myarray As Variant) As Variant
        Dim X As Long
        Dim Y As Long
        Dim Xupper As Long
        Dim Yupper As Long
        Dim tempArray As Variant
        Xupper = UBound(myarray, 2)
        Yupper = UBound(myarray, 1)

        ReDim tempArray(1 To Xupper, 1 To Yupper)
        For X = 1 To Xupper
            For Y = 1 To Yupper
                tempArray(X, Y) = myarray(Y, X)
            Next Y
        Next X
        TransposeArray = tempArray
    End Function

尝试使用最佳实践复制和粘贴过滤后的数据

1 个答案: