查找单元格匹配范围值的所有行，复制到按值命名的新工作表

Question

我必须对包含多种货币的客户数据进行报告。 与每行具有多个货币列的单个项目不同，适用于项目的每种货币都有自己的行，因此数据最终可能如下所示：

我需要做的是根据货币代码将其分解为不同的工作表。 我目前已经获得了我的 VBA 代码，我可以识别唯一货币代码值的列表，为每个值创建新的工作表，然后将数据复制到这些工作表中，但我一直坚持让它复制正确的数据到新的工作表。 目前，它只是将相同的数据复制到每个工作表，也就是说，它将“AUD - 澳元”的所有行复制到每个新创建的工作表中。

链接到虚拟文件：https ://www.dropbox.com/s/eotyqdi1wzvuzrf/Test%20Book.xlsm?dl=0

我先把我的完整代码块放在第一位，以防有人在我认为问题所在的地方之外发现它有问题，然后我再放第二块我认为是问题的代码

完整代码

Sub CopyData()
''    -----------------------------------------------------------------------------------------
''    Create new worksheet to store currency list
''    -----------------------------------------------------------------------------------------
    Sheets.Add.Name = "Currencies"
'
''    -----------------------------------------------------------------------------------------
''   Find the unique currency values
''    -----------------------------------------------------------------------------------------
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Metadata")
    Set s2 = Sheets("Currencies")
    s1.Range("A1:F300000").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes
    s1.Range("C:C").Copy s2.Range("A1")
    s2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    s2.Rows(1).Delete

'    -----------------------------------------------------------------------------------------
'   Find all rows matching currency from raw data and copy to new sheet named by currency
'    -----------------------------------------------------------------------------------------
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim test As Integer
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
Dim DataRange As Range
Dim cell As Range

'    Determine the data you want stored
      Set DataRange = Sheets("Currencies").Range("A1:A2")

'    Resize Array prior to loading data
      ReDim strArray(DataRange.Cells.Count)

'    Loop through each cell in Range and store value in Array
      For Each cell In DataRange.Cells
        strArray(x) = cell.Value
        x = x + 1
      Next cell

'    Print values to Immediate Window (Ctrl + G to view)
      For x = LBound(strArray) To UBound(strArray)
        Debug.Print strArray(x)
      Next x

    Set wsSource = Sheets("Metadata")

    NoRows = wsSource.Range("A300000").End(xlUp).Row
    DestNoRows = 1

    For Each cell In DataRange

        Set wsDest = ActiveWorkbook.Worksheets.Add
        ActiveSheet.Name = cell.Value

        For I = 1 To NoRows

            Set rngCells = wsSource.Range("A" & I & ":Z" & I)
            Found = False

            For J = 0 To UBound(strArray)
                Found = Found Or Not (rngCells.Find(strArray) Is Nothing)
            Next J

            If Found Then
                rngCells.EntireRow.Copy wsDest.Range("A" & I - 1)
                DestNoRows = DestNoRows + 1
            End If

        Next I

    Next cell

ActiveWorkbook.Save

End Sub

只是我觉得有点奇怪

'    -----------------------------------------------------------------------------------------
'   Find all rows matching currency from raw data and copy to new sheet named by currency
'    -----------------------------------------------------------------------------------------
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim test As Integer
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
Dim DataRange As Range
Dim cell As Range

'    Determine the data you want stored
      Set DataRange = Sheets("Currencies").Range("A1:A2")

'    Resize Array prior to loading data
      ReDim strArray(DataRange.Cells.Count)

'    Loop through each cell in Range and store value in Array
      For Each cell In DataRange.Cells
        strArray(x) = cell.Value
        x = x + 1
      Next cell

'    Print values to Immediate Window (Ctrl + G to view)
      For x = LBound(strArray) To UBound(strArray)
        Debug.Print strArray(x)
      Next x

    Set wsSource = Sheets("Metadata")

    NoRows = wsSource.Range("A300000").End(xlUp).Row
    DestNoRows = 1

    For Each cell In DataRange

        Set wsDest = ActiveWorkbook.Worksheets.Add
        ActiveSheet.Name = cell.Value

        For I = 1 To NoRows

            Set rngCells = wsSource.Range("A" & I & ":Z" & I)
            Found = False

            For J = 0 To UBound(strArray)
                Found = Found Or Not (rngCells.Find(strArray) Is Nothing)
            Next J

            If Found Then
                rngCells.EntireRow.Copy wsDest.Range("A" & I - 1)
                DestNoRows = DestNoRows + 1
            End If

        Next I

    Next cell

Answer 1

根据我在评论中得到的反馈，我重构为循环、过滤，然后仅复制可见单元格。 我还将列定义更改为用户输入框，这就是为什么范围看起来与原始范围明显不同的原因

For Each cell In DataRange

    code = cell.Value
    wsSource.Range("A1").AutoFilter Field:=xCurrNum, Criteria1:=code
    Set wsDest = ActiveWorkbook.Worksheets.Add
    ActiveSheet.Name = cell.Value
    wsSource.Range(xPub & "2:" & xPub & "300000").SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Range("A2")
    wsSource.Range(xIsbn & "2:" & xIsbn & "300000").SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Range("C2")
    wsSource.Range(xPrice & "2:" & xPrice & "300000").SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Range("E2")
    wsSource.Range(xDiscount & "2:" & xDiscount & "300000").SpecialCells(xlCellTypeVisible).Copy Destination:=wsDest.Range("F2")
Next cell