VBA 根据单元格改变的值改变对应单元格的值
Private Sub Worksheet_Change(ByVal Target As Range)10 On Error GoTo er:20 Application.EnableEvents = False30 If Intersect(Target, Range("I6")) Is Nothing = False Then' Range("I6").Formula = "=IF(SUM(INDIRECT(""$I$16:$I$2015""),INDIRECT(""$G$16:$G$2015""))=0,"""",SUM(INDIRECT(""$I$16:$I$2015""),INDIRECT(""$G$16:$G$2015"")))"
40 Range("I6").Formula = "=IF(SUM(INDIRECT(""$G$16:$G$2015""))=0,"""",SUM(INDIRECT(""$G$16:$G$2015"")))"50 End If60 If Intersect(Target, Range("I9")) Is Nothing = False Then
70 Range("I9").Formula = "=IF(SUM(INDIRECT(""$I$6""),INDIRECT(""$I$7""))*INDIRECT(""$I$8"")=0,"""",SUM(INDIRECT(""$I$6""),INDIRECT(""$I$7""))*INDIRECT(""$I$8""))"
80 End If90 If Intersect(Target, Range("I10")) Is Nothing = False Then
100 Range("I10").Formula = "=IF(sum($I$6,$I$7,$I$9)=0,"""",sum($I$6,$I$7,$I$9))"
110 End If120 If Intersect(Target, Range("N10")) Is Nothing = False Then
130 Range("N10").Formula = "=IF(sum($I$10,0)=0,"""",ROUND($I$10,2)*ROUND($M$10,2))"
140 End If150 If Intersect(Target, Range("N15")) Is Nothing = False Then
160 Range("N15").Formula = "=IF(SUM(INDIRECT(""$N$16:$N$2015""))=0,"""",SUM(INDIRECT(""$N$16:$N$2015"")))"
170 End If' If Intersect(Target, Range("Q15")) Is Nothing = False Then' Range("Q15").Formula = "=IF(SUM(INDIRECT(""$Q$16:$Q$2015""))=0,"""",SUM(INDIRECT(""$Q$16:$Q$2015"")))"' End If'' If Intersect(Target, Range("R15")) Is Nothing = False Then' Range("R15").Formula = "=IF(SUM(INDIRECT(""$R$16:$R$2015""))=0,"""",SUM(INDIRECT(""$R$16:$R$2015"")))"' End If'180 Application.EnableEvents = True190 If Intersect(Target, Range("D16:D2015,F16:G2015,L16:N2015")) Is Nothing = False And ckEnableEvents = True ThenDim strFormulaCLPrice As StringDim intResultCLPrice As DoubleDim strFormulaCLAmount As StringDim intResultCLAmount As DoubleDim strFormulaCLLR As StringDim intResultCLLR As Double200 strFormulaCLPrice = "{材料成本}+{材料加价}" '//材料单价
210 strFormulaCLAmount = "{材料数量}*{材料单价}" '//材料金额
220 strFormulaCLLR = "{材料数量}*{材料加价}" '//材料利润230 Application.EnableEvents = False'------材料-----------
240 strFormulaCLPrice = Replace(strFormulaCLPrice, "{材料成本}", Val(Range("L" & Target.Row).Value))
250 strFormulaCLPrice = Replace(strFormulaCLPrice, "{材料加价}", Val(Range("M" & Target.Row).Value))
260 intResultCLPrice = Application.Evaluate(strFormulaCLPrice)
270 Range("F" & Target.Row).Value = IIf(intResultCLPrice = 0, "", intResultCLPrice)280 strFormulaCLAmount = Replace(strFormulaCLAmount, "{材料数量}", Val(Range("D" & Target.Row).Value))
290 strFormulaCLAmount = Replace(strFormulaCLAmount, "{材料单价}", Val(Range("F" & Target.Row).Value))
300 intResultCLAmount = Application.Evaluate(strFormulaCLAmount)
310 Range("G" & Target.Row).Value = IIf(intResultCLAmount = 0, "", intResultCLAmount)320 strFormulaCLLR = Replace(strFormulaCLLR, "{材料数量}", Val(Range("D" & Target.Row).Value))
330 strFormulaCLLR = Replace(strFormulaCLLR, "{材料加价}", Val(Range("M" & Target.Row).Value))
340 intResultCLLR = Application.Evaluate(strFormulaCLLR)
350 Range("N" & Target.Row).Value = IIf(intResultCLLR = 0, "", intResultCLLR)360 Application.EnableEvents = True370 End If' If Intersect(Target, Range("O16:O2015")) Is Nothing = False Then''' Application.EnableEvents = False'' Dim imgFile As String' Dim pic As Picture' Dim strFileAsFileNameFullPath As String' Dim rng As Range' Dim bl As Double'' Dim ws As Worksheet' Set ws = ActiveSheet''' imgFile = GetPicFileName(Target)'' If Trim(imgFile) <> "" Then'' '--方法一，链接图片---(这里需要保留方法一，来计算方法二填充图片的尺寸）----------' Set pic = ws.Pictures.Insert(imgFile)'' ' opic_产品编码_01' picName = GetPicName(Target, False, True)'' '--方法二，填充图片-------------' Dim shMB As Shape' Set shMB = Sh_picMB.Shapes("PIC_MB")'' Dim shNew As Shape' shMB.Copy' ActiveSheet.Paste' Set shNew = Selection.ShapeRange(1)'' shNew.Fill.UserPicture (imgFile)'' Set rng = Target.Offset(0, -4)' ' On Error Resume Next'' Call ShapePicDel(Target)'' Dim intMin As Double'' intMin = Application.WorksheetFunction.Min(rng.MergeArea.Height, rng.MergeArea.Width) - 3' 'ws.Hyperlinks.Add pic.ShapeRange(1), imgFile, , "点击查看图片"' ws.Hyperlinks.Add shNew, imgFile, , "点击查看图片"'' With shNew 'pic' .Height = pic.Height' .Width = pic.Width'' .Name = picName' '.Placement = xlMoveAndSize '这个属性很关键' ' If .ShapeRange.Rotation = 0 Then' If .Rotation = 0 Then' If .Height >= .Width Then' .Height = intMin' bl = pic.Height / intMin' .Width = pic.Width / bl' Else' .Width = intMin' bl = pic.Width / intMin' .Height = pic.Height / bl' End If' End If' .top = rng.top + (rng.MergeArea.Height - .Height) / 2' .Left = rng.Left + (rng.MergeArea.Width - .Width) / 2' End With'' pic.Delete'' End If'' Range(GetSetVal("ckBill_customerRng")).Select'' Application.EnableEvents = True' End If380 Exit Sub'----------------------------------
er:
390 MsgBox err.Description
400 Application.EnableEvents = TrueEnd SubSub ShapePicDel(rng As Range)Dim ws As WorksheetDim sh As ShapeSet ws = rng.WorksheetFor Each sh In ws.ShapesIf InStr(sh.Name, Replace(rng.Address, "$", "")) > 0 Thensh.DeleteEnd IfNext sh
End SubPrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Intersect(Target, Range("G3")) Is Nothing = False ThenCancel = TrueDim strPwInput As StringDim strPw As StringstrPwInput = InputBox("请输入密码", "提示")If Trim(strPwInput) = "" ThenExit SubEnd IfstrPw = getws("数据字典").Range("C2").ValueIf Trim(strPw) = "" ThenExit SubEnd IfIf Trim(strPw) = Trim(strPwInput) ThenColumns("L:N").EntireColumn.Hidden = Not Columns("L:N").EntireColumn.HiddenEnd IfEnd IfIf Intersect(Target, Range(GetSetVal("ckBill_customerRng"))) Is Nothing = False ThenCancel = TrueSet frmSearchCustomer.rngResult = TargetfrmSearchCustomer.utype = "CK"frmSearchCustomer.DblClickClose = TruefrmSearchCustomer.Caption = "选择客户"frmSearchCustomer.Width = 500frmSearchCustomer.listInfo.Width = frmSearchCustomer.Width - 20Dim p As POINTAPIGetCursorPos pfrmSearchCustomer.StartUpPosition = 0 '手动frmSearchCustomer.Left = Target.Offset(0, -1).Width + p.X / 1.3333frmSearchCustomer.top = Target.Offset(0, -1).Height + p.Y / 1.3333frmSearchCustomer.Show 0frmSearchCustomer.initfrmSearchCustomer.Height = frmSearchCustomer.listInfo.Height + frmSearchCustomer.listInfo.top + 38End IfIf Intersect(Target, Range(GetSetVal("ckBill_selectGoodsRng"))) Is Nothing = False ThenCancel = TrueIf CheckLimited = False Then Exit SubckEnableEvents = TrueWith frmSelectInfoSet .rngResult = Target'Set frmSelectInfo.rngDetail = Range(strBillGoodsRng).BillType = "CK".DblClickClose = False.Caption = "选择产品信息".Width = GetSetVal("goods_formWidth").listInfo.Width = .Width - 20.init.Show 0End WithEnd IfIf Intersect(Target, Range(GetSetVal("ckBill_billDateRng"))) Is Nothing = False ThenCancel = TruefrmCalendar.Show vbModalIf IsNull(rtnDate) = False ThenRange(GetSetVal("ckBill_billDateRng")).Value = rtnDatestrTempVal = GetSetVal("ckBill_billNoRng")If Trim(strTempVal) <> "" ThenRange(strTempVal).Value = GetBillNo("BJ", Range(GetSetVal("ckBill_billDateRng")).Value, False) ' "自动生成"End IfEnd IfEnd IfIf Intersect(Target, Range("C5")) Is Nothing = False ThenCancel = TrueSet frmSelectPara.rngResult = TargetfrmSelectPara.BillType = ""frmSelectPara.DblClickClose = TruefrmSelectPara.Caption = "选择提交公司"frmSelectPara.Width = 280frmSelectPara.listInfo.Width = frmSelectPara.Width - 20frmSelectPara.Show 0frmSelectPara.init (GetSetVal("gsmc_list_dataRng"))End IfIf Intersect(Target, Range("A16:A2015")) Is Nothing = False ThenCancel = TrueSet frmSelectPara.rngResult = TargetfrmSelectPara.BillType = "bj"frmSelectPara.moveCol = 1frmSelectPara.DblClickClose = TruefrmSelectPara.Caption = "选择项目类别"frmSelectPara.Width = 280frmSelectPara.listInfo.Width = frmSelectPara.Width - 20frmSelectPara.Show 0frmSelectPara.init (GetSetVal("xmtype_list_dataRng"))End IfEnd SubPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)Set frmSelectInfo.rngResult = Target
End Sub
