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

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