VBA实现数据跨表复制

需求:

  1. 维护一张元器件表格,存储基础的元器件信息
  2. 维护一张产品信息表,在产品表中选择元器件进行组装,同时自动显示一些元器件的基本信息 ##实现: 首先在元器件表中新增一列隐藏列,组成唯一值,然后在产品表中每一行新增一个下拉框,当选择对应选项时,自动将元器件表中对应的字段拷贝过来
Sub CreateList()
    ''创建下拉列表
    Dim i As Long, w1 As String
    w1 = ""
    With Sheet1
        ''首先创建下拉列表数据
        For i = 7 To 5999 Step 1
            w1 = w1 & IIf(w1 <> "", ",", "")
            w1 = w1 & Trim$(.Cells(i, 9)) ''第九列
        Next
    End With

    ''sheet4的c列增加下拉框
    With Sheet4
            ''添加数据有效性
            With .Range("c7:c5999").Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=w1
                .InCellDropdown = True
            End With
    End With
End Sub
'''下面是excel的事件
Public Sub Worksheet_Change(ByVal Target As Range) '' excle 中的数据被改变时触发
Application.EnableEvents = False '' 用于标记只执行一次,否则会死循环
        Dim w1, w2, w3, w4, w5, w6 As String
        Dim columnNo As Long
        Dim rowNo As Long
        Dim splitStrCount As Long

    If Target.Column = 3 Then  ''只有第三列中的下拉框数据被改变时才处理
      splitStrCount = (Len(Target.Value) - Len(Application.WorksheetFunction.Substitute(Target.Value, "|", ""))) / Len("|") ''获取分隔符|有几个
      ''被改变的单元格位置
      columnNo = Target.Column 
      rowNo = Target.Row

      If splitStrCount = 6 Then ''6个字段都有的才处理,不合法的数据处理会报错,报错以后宏就不起作用了
        w1 = Split(Target.Value, "|")(1) ''物料编码
        w2 = Split(Target.Value, "|")(2) ''物料名称
        w3 = Split(Target.Value, "|")(3) ''物料描述
        w4 = Split(Target.Value, "|")(4) ''物料封装
        w5 = Split(Target.Value, "|")(5) ''物料品牌
        w6 = Split(Target.Value, "|")(6) ''物料类型

        ''Range("B3:Z3").Find(What:=w1).Activate ''利用excel的自动搜索功能,用于定位内容
        ''给对应的列赋值
        Cells(rowNo, columnNo + 1) = w1
        Cells(rowNo, columnNo + 2) = w2
        Cells(rowNo, columnNo + 3) = w3
        Cells(rowNo, columnNo + 4) = w4
        Cells(rowNo, columnNo + 5) = w5
        Cells(rowNo, columnNo + 6) = w6
      Else '' 数据不对的数据不处理
        Cells(rowNo, columnNo + 1) = ""
        Cells(rowNo, columnNo + 2) = ""
        Cells(rowNo, columnNo + 3) = ""
        Cells(rowNo, columnNo + 4) = ""
        Cells(rowNo, columnNo + 5) = ""
        Cells(rowNo, columnNo + 6) = ""
      End If
    End If

Application.EnableEvents = True
End Sub

效果:

需要注意的几个地方:

  1. 新建的下拉框,数据源中不能出现逗号,否则会当成分隔符自动分开两个选项
  2. 有时没有反应,把 excel 文件关掉重开就可以了
  3. 有效性中的数据不能剔重,选择的时候会有问题,所有下拉框的数据选项尽量唯一
  4. 打开文件时自动执行宏 在ThisWorkbook 对象下增加:

Private Sub Workbook_Open()
    Call Sheet4.CreateList ''要运行的宏名称
End Sub

没解决的问题:

打开的时候总会有报错,虽然不影响什么

文件下载:

链接: http://pan.baidu.com/s/10qgVW 密码: mfp9

2015-10-15 10:301