当前位置：首页 → 问答吧 → 按多个名字筛选并生成新的工作表

按多个名字筛选并生成新的工作表

时间：2011-08-10

来源：互联网

好心的高手能不能把下表按这个要求写个宏啊!
H列为业务员,比如H2为高代平,而H3是空格,筛选高代平,也要把H列高代平下面的那个空格,所在行也要筛选出来.依次类推.业务员分别为:高代平,罗立静,李松,赵峰,李洁,江玉秀,丁世隆,刘健.每个业务员都按这个筛选.
筛选一个业务员,就在表里插入工作表,并把筛选出来的剪切到新插入的这个工作表里.并且这个插入工作表的名字重命名为筛选出来业务员的名字.
比如,筛选高代平,就把所有高代平的剪切到新插入的工作表里,并工作表的名字改为高代平,每个业务员都按这个类推.

谢谢！！！！

附件

111.zip(9.25 KB)

2011-8-10 15:13, 下载次数: 3

作者: jjip123 发布时间: 2011-08-10

复制内容到剪贴板

代码:

Sub test()
Dim r As Long, rr As Long, i%, c As Object, a, sh, fadd$
r = Sheet1.Cells(65536, 1).End(xlUp).Row + 1
Set dic = CreateObject("scripting.dictionary")  '字典
For i = 2 To r
      If Not dic.exists(Sheet1.Cells(i, 8).Value) And Sheet1.Cells(i, 8) <> "" Then dic.Add Sheet1.Cells(i, 8).Value, ""
Next i
a = dic.keys
For i = 0 To dic.Count - 1
      With Sheet1.Range("H1:H" & r)
         Set c = .Find(a(i))
         If Not c Is Nothing Then
            fadd = c.Address
            Set sh = Sheets.Add(after:=Sheets(Sheets.Count)) '新增工作表
            sh.Name = a(i)
            sh.Cells(1, 1).Resize(, 8) = Sheet1.Range("A1:H1").Value '表头
            rr = sh.[A65536].End(xlUp).Row + 1
            Do
                  sh.Cells(rr, 1).Resize(2, 8) = Sheet1.Range("A" & c.Row & ":H" & c.Row + 1).Value
                  rr = sh.[A65536].End(xlUp).Row + 2
                  Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> fadd
         End If
      End With
Next i
Set dic = Nothing
End Sub