求一个筛选的代码。。

zhanghaowei · 发表于 2011-6-26 22:44

请看附件：

zhanghaowei · 发表于 2011-6-27 13:37

顶顶顶上去，高手帮忙看看

doitbest · 发表于 2011-6-27 13:44

Public Sub wer()
Dim y, x, ce, blank As Range, i, j, d, str, str1, ran1 As Range
y = ActiveSheet.UsedRange.Rows.Count
x = Cells(1, Columns.Count).End(xlToLeft).Column
For Each ce In Range(Cells(1, 1), Cells(1, x))
If ce = "" Then
If blank Is Nothing Then Set blank = ce Else Set blank = Union(blank, ce)
End If
Next ce
If Not blank Is Nothing Then blank.EntireColumn.Delete
x = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To x
For j = 1 To y
str = str & Application.Small(Range(Cells(1, i), Cells(y, i)), j)
Next j
Cells(y + 1, i) = str
str = ""
Next i
y = ActiveSheet.UsedRange.Rows.Count
For i = 1 To x
If Application.Match(Cells(y, i).Value, Rows(y), 0) <> i Then
If ran1 Is Nothing Then Set ran1 = Cells(y, i) Else Set ran1 = Union(ran1, Cells(y, i))
End If
Next i
If Not ran1 Is Nothing Then ran1.EntireColumn.Delete
Rows(y).ClearContents
End Sub

[ 本帖最后由 doitbest 于 2011-6-27 13:48 编辑 ]

doitbest · 发表于 2011-6-27 13:47

请参考附件

清风_ll · 发表于 2011-6-27 15:23

原帖由 doitbest 于 2011-6-27 13:44 发表
Public Sub wer()
Dim y, x, ce, blank As Range, i, j, d, str, str1, ran1 As Range
y = ActiveSheet.UsedRange.Rows.Count
x = Cells(1, Columns.Count).End(xlToLeft).Column
For Each ce In Range(Cells(1, ...

用一条语句就可以删除空列了
ActiveSheet.Range("1:1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete

doitbest · 发表于 2011-6-27 16:11

可不是嘛,沉浸在一条思路中,忘记思考更好的办法!谢谢!

doitbest · 发表于 2011-6-27 16:23

简化代码
Public Sub wer1()
Dim y, x, ce, blank As Range, i, j, d, str, str1, ran1 As Range
y = ActiveSheet.UsedRange.Rows.Count
x = Cells(1, Columns.Count).End(xlToLeft).Column
ActiveSheet.Range([a1], Cells(1, x)).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
x = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To x
For j = 1 To y
str = str & Application.Small(Range(Cells(1, i), Cells(y, i)), j)
Next j
Cells(y + 1, i) = str
str = ""
Next i
y = ActiveSheet.UsedRange.Rows.Count
For i = 1 To x
If Application.Match(Cells(y, i).Value, Rows(y), 0) <> i Then
If ran1 Is Nothing Then Set ran1 = Cells(y, i) Else Set ran1 = Union(ran1, Cells(y, i))
End If
Next i
If Not ran1 Is Nothing Then ran1.EntireColumn.Delete
Rows(y).ClearContents
End Sub

doitbest · 发表于 2011-6-30 17:09

感谢清风版主两次相助！！

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

[求助] 求一个筛选的代码。。

评分