Question

我的数据如下。

更新了问题

Sub Solution()
  Dim shData As Worksheet
  Set shData = Sheets("Sheet1")    'or other reference to data sheet
  Dim coll As Collection, r As Range, j As Long
  Dim myArr As Variant
  Dim shNew As Worksheet

  shData.Activate

  'get unique values based on Excel features
  Range("a1").AutoFilter

  Set coll = New Collection

  On Error Resume Next

  For Each r In Range("A1:A10")
    coll.Add r.Value, r.Value
  Next r

  On Error GoTo 0
  'Debug.Print coll.Count

  For j = 1 To coll.Count
    MsgBox coll(j)
    myArr = coll(j)
  Next j

  Range("a1").AutoFilter

  Dim i As Long

  For i = 0 To UBound(myArr)
    shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
      Operator:=xlAnd
    On Error Resume Next
    Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents

    If Err.Number = 0 Then
      Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
    Else
      Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
      shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
      shNew.Name = myArr(i)
      Err.Clear
    End If
 Next i

 'removing filter in master sheet
 shData.Range("a1").AutoFilter

 End Sub

当我在宏上运行时，我不知道它为什么在Type Mismatch Error之后给出MsgBox coll(j)，只是我想将数据存储在数组中并且我传递了这些数据，我在这里使用{ {1}}如果For Each r In Range("A1:A10")长度是静态的，我怎样才能找到最后写的列？

Answer 1

在尝试回答这个问题之前，我想写一些我认为你想要完成的事情;当你确认这是你想要做的事情时，我将尝试帮助你获得工作代码来实现它。这通常是用注释完成的，但到目前为止注释的线程有点脱节，而且代码非常复杂......

您在表格中有数据（称为“sheet1” - 可能是其他内容）
第一列包含可能重复的某些值
你不知道可能有多少列...你想知道虽然
您尝试在A列中找到每个唯一值（称之为“键值”），并在消息框中显示它（一次一个）。这看起来更像是调试步骤，而不是最终程序的实际功能。
然后打开A列上的自动过滤器;仅选择与特定值匹配的行
使用与工作表名称相同的值，您可以看到是否存在这样的工作表：如果存在，则清除其内容;如果没有，那么你在工作簿的末尾创建它（并给它键的名称）
您在sheet1上的A列中选择具有相同（键）值的所有行，并将它们复制到名称等于您在其上过滤的A列中的值的工作表
您想对A列
当一切都完成后，我相信你（至少）有一张纸，而不是你在A栏中的关键值（你还有初始数据表）;但是你不删除任何“多余的”表（带有其他名称）。每张工作表只包含与sheet1当前内容相对应的数据行（删除任何早期数据）。
在操作过程中，您可以打开和关闭自动过滤;您希望最终禁用自动过滤器。

请确认这确实是您尝试做的事情。如果您可以了解A列中值的格式，那将会很有帮助。我怀疑有些事情可以比你现在做的更有效率地完成。最后，我想知道以这种方式组织数据的整个目的可能是以特定的方式组织数据，还是可以进行进一步的计算/图表等。内置的各种函数excel（VBA）可以制作数据提取的工作更容易 - 很少有这种数据重新排列是完成特定工作所必需的。如果您愿意对此发表评论......

以下代码执行以上所有操作。请注意使用For Each和函数/子例程来处理某些任务（unique，createOrClear和worksheetExists）。这使得顶级代码更易于阅读和理解。另请注意，错误捕获仅限于一小部分，我们检查是否存在工作表 - 对我而言，它运行没有问题;如果发生任何错误，请告诉我工作表中的内容，因为这可能会影响发生的情况（例如，如果列A中的单元格包含工作表名称中不允许的字符，例如/\!另请注意，您的代码正在删除“CurrentRegion”。根据您要实现的目标，“UsedRange”可能更好......

Option Explicit

Sub Solution()
  Dim shData As Worksheet
  Dim nameRange As Range
  Dim r As Range, c As Range, A1c As Range, s As String
  Dim uniqueNames As Variant, v As Variant

  Set shData = Sheets("Sheet1")  ' sheet with source data
  Set A1c = shData.[A1]          ' first cell of data range - referred to a lot...
  Set nameRange = Range(A1c, A1c.End(xlDown)) ' find all the contiguous cells in the range

  ' find the unique values: using custom function
  ' omit second parameter to suppress dialog
  uniqueNames = unique(nameRange, True)

  Application.ScreenUpdating = False ' no need for flashing screen...

  ' check if sheet with each name exists, or create it:
  createOrClear uniqueNames

  ' filter on each value in turn, and copy to corresponding sheet:
  For Each v In uniqueNames
    A1c.AutoFilter Field:=1, Criteria1:=v, _
      Operator:=xlAnd
    A1c.CurrentRegion.Copy Sheets(v).[A1]
  Next v

  ' turn auto filter off
  A1c.AutoFilter

  ' and screen updating on
  Application.ScreenUpdating = True

End Sub

Function unique(r As Range, Optional show)
  ' return a variant array containing unique values in range
  ' optionally present dialog with values found
  ' inspired by http://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array
  Dim d As Object
  Dim c As Range
  Dim s As String
  Dim v As Variant

  If IsMissing(show) Then show = False

  Set d = CreateObject("Scripting.Dictionary")

  ' dictionary object will create unique keys
  ' have to make it case-insensitive
  ' as sheet names and autofilter are case insensitive
  For Each c In r
    d(LCase("" & c.Value)) = c.Value
  Next c

  ' the Keys() contain unique values:
  unique = d.Keys()

  ' optionally, show results:
  If show Then
    ' for debug, show the list of unique elements:
    s = ""
    For Each v In d.Keys
      s = s & vbNewLine & v
    Next v
    MsgBox "unique elements: " & s
  End If

End Function

Sub createOrClear(names)
  Dim n As Variant
  Dim s As String
  Dim NewSheet As Worksheet

  ' loop through list: add new sheets, or delete content
  For Each n In names
    s = "" & n ' convert to string
    If worksheetExists(s) Then
      Sheets(s).[A1].CurrentRegion.Clear ' UsedRange might be better...?
    Else
      With ActiveWorkbook.Sheets
        Set NewSheet = .Add(after:=Sheets(.Count))
        NewSheet.Name = s
      End With
    End If
  Next n

End Sub

Function worksheetExists(wsName)
' adapted from http://www.mrexcel.com/forum/excel-questions/3228-visual-basic-applications-check-if-worksheet-exists.html
  worksheetExists = False
  On Error Resume Next
  worksheetExists = (Sheets(wsName).Name <> "")
  On Error GoTo 0
End Function

Answer 2

当您向集合添加内容时，密钥必须是字符串，因此请使用：

coll.Add r.Value, CStr(r.Value)

而不是：

coll.Add r.Value, r.Value

您仍在将coll(j)分配给不是数组的Variant 。你需要：

ReDim myArr(1 to coll.Count)

在你的for循环之前然后在循环中：

myArr(j) = coll(j)

MsgBox后输入Mismatch Error

2 个答案: