VBA 提取数据

背景

工作上有一项内容是将G表格中的参数填写到X表格中，有时一走神就容易出错。于是就想用VBA一键提取，省的一个一个数字去复制。

对象说明

G表格和X表格相似，G与X的格式都是固定的
X表格是一个模板，若选择G1，则提取G1的参数，若选择G2，则提取G2的参数
G表格的子页数不固定

解决步骤

选择G表格（这一步直接利用之前做相同需求的代码）。

Option Compare Text '不区分大小写比较文本
Option Explicit
Sub 按钮1_Click()
Application.ScreenUpdating = False   '关闭屏幕刷新Dim filepath As String
With Application.FileDialog(msoFileDialogFilePicker)'开启选择窗口
  .Title = "请选择相应的工艺卡"
  .AllowMultiSelect = False '只允许选择单一文件
  .InitialFileName = ThisWorkbook.Path '默认打开路径为本工作簿的路径
  .Filters.Clear '清除现有的文件类型
  .Filters.Add "Excel", "*.xls, *.xlsx", 1 '添加选择文件类型
  .FilterIndex = 1
  If .Show = -1 Then '判定有无选择文件
    filepath = .SelectedItems(1)
    MsgBox "选择了：" & .SelectedItems(1), vbInformation
  Else
    MsgBox "未选择任何文件，请重新选择！", vbExclamation
    Exit Sub
  End If
End With

将G表格中子页的参数填到X表格的子页中：尝试过使用固定位置一一对应填进去，但是显得很臃肿，而且一但G表格的参数位置稍微一变化就会出错。所以利用G表格中的参数名称锁定参数，会比较灵活一点。

Dim ProcessCard As Workbook
Dim Process As Worksheet
Dim ProItem As Range
Dim Protext As String

Dim ZhiCheng(5) As String '定义制程（G与X表格的子页名称）的数组
ZhiCheng(0) = "BM"
ZhiCheng(1) = "R"
ZhiCheng(2) = "G"
ZhiCheng(3) = "B"
ZhiCheng(4) = "OC"
ZhiCheng(5) = "PS"
Dim A As Variant
Dim B As String
Set ProcessCard = GetObject(filepath)
Dim testcount As Integer
testcount = 0

For Each Process In ProcessCard.Worksheets '对G子页进行循环
  For Each A In ZhiCheng '对数组进行循环'
    If InStr(Process.Name, A) Then '若G与数组中的元素对应，开始提取
      ThisWorkbook.Sheets(A).Range("C5:D5,C6:C7,D8,F8,G8,K8,L8,M8,N8,O8,P8") = "" '初始化置空
      For Each ProItem In Process.Range("A1", "A70") '在各页的第一页寻找参数名称
        Protext = Trim(ProItem.Text) '去掉字符前后的空格
        
        Select Case ProItem.Text
        Case "适用产品"
        ThisWorkbook.Sheets(A).Range("C5") = ProItem.Offset(0, 1).Text  '直接复制粘贴参数
    
        Case "Coating 速度"
        B = ProItem.Offset(0, 1).Text
        B = Replace(B, "mm/s", "")
        ThisWorkbook.Sheets(A).Range("F8") = B '替换掉参数里面的单位
    
        Case "COT Dispense Speed"
        B = ProItem.Offset(0, 1).Text
        B = Left(B, 4)
        ThisWorkbook.Sheets(A).Range("G8") = B'只选择参数的前四位（容易出bug)
        
        End Select
      Next
    End If
  Next
Next

'判断参数是否为空
For Each A In ZhiCheng '对制程进行循环
 If ThisWorkbook.Sheets(A).Range("C5") = "" Then '如果为空则提示
testcount = testcount + 1
MsgBox "sheet " & A & " C5 为空，请检查工艺卡格式" & Chr(13) & "或手动填入参数"
End If
Next
If testcount = 0 Then
MsgBox "提取成功！"
End If

GetObject(filepath).Close '关闭打开的工作簿

总结

利用循环解决了位置不固定的问题，其中比较麻烦的是对参数的处理，有的是直接复制，有的是替换单位，有的无法识别单位符号的就选用前四位。

更新记录

v1.1 添加初始化置空，避免未能提取参数的情况下保存上次记录，造成误会。
v1.2 加入判断函数（是否全部提取成功），使用Compare Text声明及Trim函数。

Last modified on 2020-09-06