[已解决]谢谢爱疯老师，请看看我错在哪儿了

lhj323323

hUoTtXc3.rar (23.1 KB, 下载次数: 13)

2010-11-3 17:40 上传

点击文件名下载附件
[求助]请看看我错在哪儿了

老师：

上传的附件中有三个按纽，均为了完成同一个目的，但是有点错，请看看我错在哪儿了，谢谢了

[此贴子已经被作者于2010-11-3 20:55:02编辑过]

最佳答案

月排行榜 / 总排行榜

爱疯

2010-11-3 20:33

Sub 提取1()    '方法1
    Dim arr(), arr2(), i, s, t

    t = Timer
    Application.ScreenUpdating = False
    arr = Sheet2.Range("a5:u" & Sheet2.[c65536].End(xlUp).Row)    '[数据源]C列客户编号
    ReDim arr2(1 To UBound(arr), 1 To 5)

    For i = 1 To UBound(arr)
        If Len(arr(i, 3)) <> 0 Then
            If arr(i, 3) <> "客户编号" Then
                s = s + 1
                arr2(s, 1) = arr(i, 12)     '参考码3/分配号
                arr2(s, 2) = arr(i, 1)     '公司代码
                arr2(s, 3) = arr(i, 6)     '客户名称
                arr2(s, 4) = arr(i, 1) & arr(i, 12) & arr(i, 6)       '客户名称2
                arr2(s, 5) = arr(i, 15)     '金额
            End If
        End If
    Next i

    With Sheet3
        .Columns("A:E").Clear
        .Range("a1").Resize(s, 5) = arr2
    End With
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

跳转到最佳答案楼层

爱疯

Sub 提取1()    '方法1
    Dim arr(), arr2(), i, s, t

    t = Timer
    Application.ScreenUpdating = False
    arr = Sheet2.Range("a5:u" & Sheet2.[c65536].End(xlUp).Row)    '[数据源]C列客户编号
    ReDim arr2(1 To UBound(arr), 1 To 5)
   
    For i = 1 To UBound(arr)
        'If arr(i , 16) <= aa And arr(i , 16) >= Sht2.[m27] Then
        'If arr(i , 3) <> "" And arr(i , 3) <> "客户编号" Then
        If arr(i, 3) <> "" Then
            'If Len(arr(i , 3)) = 0 Then
            s = s + 1
            arr2(s, 1) = arr(i, 12)     '参考码3/分配号
            arr2(s, 2) = arr(i, 1)     '公司代码
            arr2(s, 3) = arr(i, 6)     '客户名称
            arr2(s, 4) = arr(i, 1) & arr(i, 12) & arr(i, 6)       '客户名称2
            arr2(s, 5) = arr(i, 15)     '金额
        End If
    Next i
   
    With Sheet3
        .Columns("A:E").Clear
        .Range("a1").Resize(s, 5) = arr2
    End With
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub

[em09]

那么的帅

3个都改好了，看看还有什么问题，改的地方在代码里注明了

 

syh5AqAP.rar (26.18 KB, 下载次数: 14)

2010-11-3 18:19 上传

点击文件名下载附件
[求助]请看看我错在哪儿了

lhj323323

谢谢爱疯老师和那么的帅老师

不过，您们两位都只实现了将[数据源]C列不为空的记录提取出来

而我的需求是将C列不为空，同时不等于“客户编号”这四个汉字的记录提取出来，请再看看该怎么改？

爱疯

Sub 提取1()    '方法1
    Dim arr(), arr2(), i, s, t

    t = Timer
    Application.ScreenUpdating = False
    arr = Sheet2.Range("a5:u" & Sheet2.[c65536].End(xlUp).Row)    '[数据源]C列客户编号
    ReDim arr2(1 To UBound(arr), 1 To 5)

    For i = 1 To UBound(arr)
        If Len(arr(i, 3)) <> 0 Then
            If arr(i, 3) <> "客户编号" Then
                s = s + 1
                arr2(s, 1) = arr(i, 12)     '参考码3/分配号
                arr2(s, 2) = arr(i, 1)     '公司代码
                arr2(s, 3) = arr(i, 6)     '客户名称
                arr2(s, 4) = arr(i, 1) & arr(i, 12) & arr(i, 6)       '客户名称2
                arr2(s, 5) = arr(i, 15)     '金额
            End If
        End If
    Next i

    With Sheet3
        .Columns("A:E").Clear
        .Range("a1").Resize(s, 5) = arr2
    End With
    Application.ScreenUpdating = True
    MsgBox Timer - t
End Sub