求一个筛选的代码。。

zhanghaowei

请看附件：

zhanghaowei

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

doitbest

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

请参考附件

清风_ll

原帖由 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

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

doitbest

简化代码
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

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