[已解决]求助生成清单的宏， 急求， 有图 有附件，请高手帮忙

kidd1217

求助生成清单的宏， 急求， 有图 有附件，请高手帮忙

最佳答案

月排行榜 / 总排行榜

zjdh

2013-3-1 16:38

我这简易一点
Sub 生成图纸目录()
    D = InputBox("请输入日期", "日期输入", "2013/3/8")
    ARR = Sheets("28FEB13 ").Range("C3:S" & Sheets("28FEB13 ").Range("C65536").End(3).Row)
    ReDim BRR(1 To UBound(ARR), 1 To 9)
    DT = DateValue(D)
    For I = 1 To UBound(ARR)
        If ARR(I, 17) = DT Then
            T = T + 1
            BRR(T, 1) = T
            BRR(T, 3) = ARR(I, 4)
            BRR(T, 5) = "A3"
            BRR(T, 6) = ARR(I, 1)
            BRR(T, 7) = ARR(I, 2)
            BRR(T, 8) = ARR(I, 17)
            BRR(T, 9) = ARR(I, 16)
        End If
    Next
    Sheets("图纸目录").Range("A5:I65536").ClearContents
    If T = "" Then MsgBox "没有该日期图纸！": Exit Sub
    Sheets("图纸目录").Range("A5").Resize(T, 9) = BRR
End Sub

跳转到最佳答案楼层

kidd1217

我自己用一个个循环实在太慢了~~~~~~~~~~~~~~~~~~
Sub 生成图纸目录()

Dim b As Integer

For b = 3 To Sheets("28FEB13").Range("c65536").End(xlUp).Row


If Sheets("28FEB13").Range("s" & b).Value = "2013/3/8" Then


Sheets("图纸目录").Range("c65536").End(xlUp).Offset(1, 0) = Sheets("28FEB13").Range("f" & b)



End If


Next b

kidd1217

我只写了一小段
这一个条件 就慢死了~~~

再加几个条件 岂不是更慢

kidd1217

有人帮下忙吗？？？？

那么的帅

kidd1217 发表于 2013-3-1 14:57
有人帮下忙吗？？？？

设置一个INPUBOX  输入日期，如果日期等于 sheets(28FEB13 ) 的S列的日期，
要在图纸目录显示所有符合条件的吗？

kidd1217

那么的帅 发表于 2013-3-1 15:19
设置一个INPUBOX  输入日期，如果日期等于 sheets(28FEB13 ) 的S列的日期，
要在图纸目录显示所有符合条 ...

是的
     麻烦您了

那么的帅

kidd1217 发表于 2013-3-1 15:34
是的
     麻烦您了

点击  提取数据 按钮，出现 窗口，按照 上方的说明操作即可。

296070-VBA-窗体-日期控件-根据日期条件提取数据.rar (150.68 KB, 下载次数: 14)

2013-3-1 15:55 上传

点击文件名下载附件

zjdh

我这简易一点
Sub 生成图纸目录()
    D = InputBox("请输入日期", "日期输入", "2013/3/8")
    ARR = Sheets("28FEB13 ").Range("C3:S" & Sheets("28FEB13 ").Range("C65536").End(3).Row)
    ReDim BRR(1 To UBound(ARR), 1 To 9)
    DT = DateValue(D)
    For I = 1 To UBound(ARR)
        If ARR(I, 17) = DT Then
            T = T + 1
            BRR(T, 1) = T
            BRR(T, 3) = ARR(I, 4)
            BRR(T, 5) = "A3"
            BRR(T, 6) = ARR(I, 1)
            BRR(T, 7) = ARR(I, 2)
            BRR(T, 8) = ARR(I, 17)
            BRR(T, 9) = ARR(I, 16)
        End If
    Next
    Sheets("图纸目录").Range("A5:I65536").ClearContents
    If T = "" Then MsgBox "没有该日期图纸！": Exit Sub
    Sheets("图纸目录").Range("A5").Resize(T, 9) = BRR
End Sub