ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 263|回复: 0

[求助] 求VBA条件查询

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-10-27 14:59 | 显示全部楼层 |阅读模式
根据批号查询 CF表中的成分  支数  捻度   计划车速  
显示在C/D/E/F列中
再计算折产  折产公式(支数×捻度×混产÷52÷680)(显示在M列,R列,V列,AC列)
还有单本混  单折52  单折680(逻辑 根据批号查找CF列中L列,第一位是1时AT列显示三个班的混产合计,AU列显示三个班的折52产量合计(折52:混×支数÷52),  AV列显示三个班的折680产量合计)


因为运行错误,    请大神看以下代码如何改正及优化   

Sub atest()
    Application.ScreenUpdating = False: Application.Calculation = xlManual    ' 手工计算
    Worksheets("产量").Activate
    Dim T1 As Date: T1 = Timer    ' 记时
    Dim arr, brr, crr(), d As Object, i&, R
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("CF").Range("e2").CurrentRegion   ' 将数据库表赋值于数组arr
    For i = 2 To UBound(arr)
        d("" & arr(i, 1)) = i  ' 将批号(工艺)加入字典
    Next
    With ActiveSheet
        brr = .Range("b4:F454").Value   ' 将区域加入字典brr
        ReDim crr(1 To UBound(brr), 1 To 5)
        For i = 1 To UBound(brr)
            R = d("" & brr(i, 1))  ' 循环获取批号在字典中的行号
            If R <> "" Then
                crr(i, 2) = arr(R, 6)  ' 将arr数组中符合条件的记录赋值数组crr,对应列号
                crr(i, 3) = arr(R, 3)
                crr(i, 4) = arr(R, 5)
                crr(i, 5) = arr(R, 9)
            End If
            crr(i, 1) = brr(i, 1)
        Next
        .[b4].Resize(i - 2, 5) = crr    ' 一次性赋值
        ' *****************
        Dim mRow&, AR(), BR(), CR(), DR(), j As Long
        mRow = .Cells(.Rows.Count, 1).End(3).Row  ' 获取A列最大行号
        arr = .Range("A4:BF" & mRow).Value   ' 将数据区域赋值于数组arr
        ' 重定义数组大小,因为你表中有公式,区域不连续,所以,只能定义几个数组分别写入,从而达到保留公式的目的
        ReDim AR(1 To UBound(arr), 1 To 1)
        ReDim BR(1 To UBound(arr), 1 To 1)
        ReDim CR(1 To UBound(arr), 1 To 1)
        ReDim DR(1 To UBound(arr), 1 To 1)
        ReDim ER(1 To UBound(arr), 1 To 1)
        For i = 1 To UBound(arr)  ' 根据条件,循环赋值
            If Val(arr(i, 11)) = 0 Or Val(arr(i, 4)) = 0 Or Val(arr(i, 5)) = 0 Then AR(i, 1) = Empty Else AR(i, 1) = VBA.Round(Val(arr(i, 11)) * Val(arr(i, 4)) * Val(arr(i, 5)) / 52 / 680, 1)
            If Val(arr(i, 16)) = 0 Or Val(arr(i, 4)) = 0 Or Val(arr(i, 5)) = 0 Then BR(i, 1) = Empty Else BR(i, 1) = VBA.Round(Val(arr(i, 16)) * Val(arr(i, 4)) * Val(arr(i, 5)) / 52 / 680, 1)
            If Val(arr(i, 21)) = 0 Or Val(arr(i, 4)) = 0 Or Val(arr(i, 5)) = 0 Then CR(i, 1) = Empty Else CR(i, 1) = VBA.Round(Val(arr(i, 21)) * Val(arr(i, 4)) * Val(arr(i, 5)) / 52 / 680, 1)
            If Val(arr(i, 13)) = 0 And Val(arr(i, 18)) = 0 And Val(arr(i, 23)) = 0 Then DR(i, 1) = Empty Else DR(i, 1) = VBA.Round(Val(arr(i, 13)) + Val(arr(i, 18)) + Val(arr(i, 23)), 1)
         If Left(Application.Worksheetsfunction.VLookup(Cells(i, 2), Worksheets("CF").Range("$E2:$M10080"), 8, 0), 1) = "1" Then
                ER(i, 1) = Val(arr(i, 27))
            End If
            Next
        ' 将赋值后的数组写入单元格
        .Range("AT4").Resize(UBound(arr), 1).Value = ER
        .Range("M4").Resize(UBound(arr), 1).Value = AR
        .Range("R4").Resize(UBound(arr), 1).Value = BR
        .Range("W4").Resize(UBound(arr), 1).Value = CR
        .Range("AC4").Resize(UBound(arr), 1).Value = DR
        ' --------------以下为重新写入单元格公式
        ' *** 一组合计
        .Range("K144").FormulaR1C1 = "=SUM(R[-140]C:R[-1]C)"
        .Range("K144").Copy
        .Range("L144:BF144").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ' *** 二组合计
        .Range("K285").FormulaR1C1 = "=SUM(R[-140]C:R[-7]C)"
        .Range("K285").Copy
        .Range("L285:BF285").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ' *** 三组合计
        .Range("K370").FormulaR1C1 = "=SUM(R[-63]C:R[-42]C)"
        .Range("K370").Copy
        .Range("L370:BF370").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ' *** 四组合计
        .Range("K455").FormulaR1C1 = "=SUM(R[-84]C:R[-1]C)"
        .Range("K455").Copy
        .Range("L455:BF455").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ' *** 总计
        .Range("K456").FormulaR1C1 = "=SUM(R[-312]C,R[-171]C,R[-86]C,R[-1]C)"
        .Range("K456").Copy
        .Range("L456:BF456").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False: Set d = Nothing
        MsgBox "数据更新已完成,用时约: " & Format(Timer - T1, "0.00") & " 秒. ", 64 + 0, "提醒"
        With .Range("b4:B454")
            .EntireRow.Hidden = False  ' 显示所有行
            .SpecialCells(xlCellTypeBlanks).Rows.Hidden = True  ' 隐藏区域内的空行
        End With
        .Range("b4").Select
          End With
    Application.ScreenUpdating = True: Application.Calculation = xlAutomatic    ' 自动计算
End Sub

求字典解决.rar

301.13 KB, 下载次数: 5

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-2-28 10:10 , Processed in 0.452522 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表