[已解决]提取特殊数据的问题

Baibdu

附件 提数附件.zip (35.9 KB, 下载次数: 2)

2015-1-7 16:09 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

爱疯

2015-1-7 16:44

Sub Click()
    Dim A, i%, j%, x$, r%, c%
    Application.ScreenUpdating = False

    '1）指定
    x = Application.InputBox("两位数:", "输入")
    If x = False Or Len(x) <> 2 Or VBA.IsNumeric(x) = False Then End
    x = CStr(x)

    '2）查询
    A = Range("a1").CurrentRegion
    r = UBound(A): c = UBound(A, 2)

    For j = 1 To c
        For i = 1 To r
            If x <> Right(A(i, j), 2) Then A(i, j) = ""
        Next i
    Next j

    '3）输出
    Sheets(2).Activate
    Range("a1").CurrentRegion.ClearContents
    Range([a1], Cells(r, c)) = A
    Range([a1], Cells(r, c)).SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
End Sub
提数附件2.rar (41.07 KB, 下载次数: 6)

2015-1-7 16:43 上传

点击文件名下载附件

跳转到最佳答案楼层

爱疯

Sub Click()
    Dim A, i%, j%, x$, r%, c%
    Application.ScreenUpdating = False

    '1）指定
    x = Application.InputBox("两位数:", "输入")
    If x = False Or Len(x) <> 2 Or VBA.IsNumeric(x) = False Then End
    x = CStr(x)

    '2）查询
    A = Range("a1").CurrentRegion
    r = UBound(A): c = UBound(A, 2)

    For j = 1 To c
        For i = 1 To r
            If x <> Right(A(i, j), 2) Then A(i, j) = ""
        Next i
    Next j

    '3）输出
    Sheets(2).Activate
    Range("a1").CurrentRegion.ClearContents
    Range([a1], Cells(r, c)) = A
    Range([a1], Cells(r, c)).SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
End Sub
提数附件2.rar (41.07 KB, 下载次数: 6)

2015-1-7 16:43 上传

点击文件名下载附件