[已解决]再问一个贻笑大方的问题。

wshnyy · 发表于 2012-11-20 12:49

本帖最后由 wshnyy 于 2012-11-20 13:06 编辑

sub dataautofilter()
worksheets("sheet1") .range("A23").autofilter field:=1, criterial:= "service"
end sub
这个是excel 2003 版的。
请问，2007 版的该怎样写？

非常感谢

另外，我想把筛选出来的内容，copy 到 sheet3的range（“D5”）下。

应该怎么办？

最佳答案

月排行榜 / 总排行榜

爱疯

2012-11-20 15:59

Sub Test()
Dim sh As Worksheet, d As Object
Dim i%, j&, jj&, x%
Dim arr1, arr2, k

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'删除总表以外的所有工作表
For Each sh In Worksheets
      If sh.Name <> Worksheets(1).Name Then
         sh.Delete
      End If
Next sh

'赋初值
Set d = CreateObject("Scripting.Dictionary")
arr1 = Range("b9").CurrentRegion '注意修改
arr2 = arr1
x = InputBox("按数据源的第几列分:", , 1)

'判断
If VBA.IsNumeric(x) = False Then
      MsgBox "输入列号不合法,请重新输入!", 48, "出错了"
      End
End If
'建立分表名称数组
For i = 2 To UBound(arr1, 1)
      If Len(arr1(i, x)) Then d(arr1(i, x)) = ""
Next i
k = d.keys
'循环每个新表
For i = 0 To UBound(k)
      Sheets.Add after:=Sheets(Sheets.Count)
      ActiveSheet.Name = i 'k(i)
      '循环每行
      For j = 1 To UBound(arr1, 1)
         '如果列值不是分表名称,则整行清零
         If arr1(j, x) <> k(i) And j <> 1 Then
            '第j行整行清零
            For jj = 1 To UBound(arr1, 2)
                  arr1(j, jj) = ""
            Next jj
         End If
      Next j
      Range("a1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
      Range("a1:a" & UBound(arr1, 1)).SpecialCells(xlCellTypeBlanks).Delete (3)
      '恢复arr1数据
      arr1 = arr2
Next i

Sheets(1).Select
End Sub

筛选3.rar (22.43 KB, 下载次数: 10)

chuanqi3 · 发表于 2012-11-20 13:00

一样的啊，有区别吗？

wshnyy · 发表于 2012-11-20 13:03

有呀。我在excel 2007上运行出错。

要不是我的上面程序写错？

蝶·舞 · 发表于 2012-11-20 13:16

自动筛选？再自己录制一个宏看看呗

wshnyy · 发表于 2012-11-20 13:36

蝶·舞发表于 2012-11-20 13:16
自动筛选？再自己录制一个宏看看呗

怎样录制呀？能帮个忙吗？谢谢

无聊的疯子 · 发表于 2012-11-20 14:02

既然是想复制那就用高级筛选吧

Range.AdvancedFilter

看一下这个的帮助，应该很简单的！！

无聊的疯子 · 发表于 2012-11-20 14:08

http://www.excelpx.com/thread-289214-1-1.html

这里有一个简单的示例

如果是要多条件，只需要增加条件区域就可以了
条件区域是要求包含标题的！！
并用支持模糊查找
比如大于10 则 >10

hwc2ycy · 发表于 2012-11-20 14:53

Sub dataautofilter()
Worksheets("Sheet1").Range("A23").CurrentRegion.AutoFilter field:=1, Criteria1:="service"
End Sub

复制代码

A23那块区域是否有内容？

wshnyy · 发表于 2012-11-20 15:08

hwc2ycy 发表于 2012-11-20 14:53
A23那块区域是否有内容？

不好意思，应该是A33

老师：

我的例子见附件。

我想把sheet1中的表，把service中的6项，依次筛选后，分别复制到sheet2 到sheet7中的range（“C6”）。

帮我看看该怎么办。。

我是大菜鸟。。。谢谢

爱疯 · 发表于 2012-11-20 15:59

Sub Test()
Dim sh As Worksheet, d As Object
Dim i%, j&, jj&, x%
Dim arr1, arr2, k

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'删除总表以外的所有工作表
For Each sh In Worksheets
      If sh.Name <> Worksheets(1).Name Then
         sh.Delete
      End If
Next sh

'赋初值
Set d = CreateObject("Scripting.Dictionary")
arr1 = Range("b9").CurrentRegion '注意修改
arr2 = arr1
x = InputBox("按数据源的第几列分:", , 1)

'判断
If VBA.IsNumeric(x) = False Then
      MsgBox "输入列号不合法,请重新输入!", 48, "出错了"
      End
End If
'建立分表名称数组
For i = 2 To UBound(arr1, 1)
      If Len(arr1(i, x)) Then d(arr1(i, x)) = ""
Next i
k = d.keys
'循环每个新表
For i = 0 To UBound(k)
      Sheets.Add after:=Sheets(Sheets.Count)
      ActiveSheet.Name = i 'k(i)
      '循环每行
      For j = 1 To UBound(arr1, 1)
         '如果列值不是分表名称,则整行清零
         If arr1(j, x) <> k(i) And j <> 1 Then
            '第j行整行清零
            For jj = 1 To UBound(arr1, 2)
                  arr1(j, jj) = ""
            Next jj
         End If
      Next j
      Range("a1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
      Range("a1:a" & UBound(arr1, 1)).SpecialCells(xlCellTypeBlanks).Delete (3)
      '恢复arr1数据
      arr1 = arr2
Next i

Sheets(1).Select
End Sub

筛选3.rar (22.43 KB, 下载次数: 10)

		自动登录	找回密码
密码			注册

[已解决]再问一个贻笑大方的问题。

相关帖子