将其他表格数据提取到文件里，请帮忙翻译翻译

lxg315

      工作中需要将测量数据提取到报告里面，在前面各位的帮助下重新整理了思路，提取的步骤如下，请帮忙“翻译”成程序，谢谢
步骤1：如图片1所示：表1黄色背景的41这个尺寸，匹配报告表尺寸这一列的41这个尺寸，将表1的测量数据41.004填写到报告表sample(1)这列，同时再将具有唯一性的“距离1-X距离”填写到报表右边，以此类推，将表1黄色背景尺寸所对应的测量数值全部提取到报告表对应位置
步骤2：:报表上的尺寸有可能有相同的，比如3个孔尺寸相同。就按照表1里面的测量数据顺序填写就行
步骤3：如图片2所示，根据报告表的唯一性的“距离1-X距离”匹配表2的唯一性的“距离1-X距离”由此将测量数值41.006填写到报告sample(2)这一列
步骤4：当样品数量超过5个时，在sample(5)后面插入sample(6)这一列将表6的测量数据填写完成，有N个样品，需要sample(N)列
步骤5：在报告表末尾做一个输入数据按钮，点此按钮就开始抓取数据。
    周末人气旺盛，先感谢大家。

3190496160

先循环表一，根据尺寸匹配到Sample(1)和尺寸识别码，然后，后面的表2-表6，都是根据表1中匹配到的   尺寸识别码 ，匹配到Sample(6)到 Sample(6)？？？？？

lxg315

3190496160 发表于 2023-3-11 09:05
先循环表一，根据尺寸匹配到Sample(1)和尺寸识别码，然后，后面的表2-表6，都是根据表1中匹配到的   尺寸识 ...

是的，就是这个意思。每次测量样品的数量不定，比如可能是15个，可能100个，所以这里还不能写成死的。但是我不会VBA，还请大神出手相救啊

3190496160

lxg315 发表于 2023-3-11 10:04
是的，就是这个意思。每次测量样品的数量不定，比如可能是15个，可能100个，所以这里还不能写成死的。但 ...

说起来容易做起来难，其实是一个不小的活

lxg315

3190496160 发表于 2023-3-11 10:23
说起来容易做起来难，其实是一个不小的活

是的，不会VBA，惭愧

3190496160

Sub 数据匹配()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\"
With Sheets("SIR")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a8:n" & r - 8)
    f = Dir(lj & "1.xls*")
    If f = "" Then MsgBox "找不到文件1": End
    Set wb = Workbooks.Open(lj & f, 0)
    With wb.Worksheets(1)
        rs = .Cells(Rows.Count, 2).End(xlUp).Row
        br = .Range("a8:g" & rs)
    End With
    wb.Close False
    For i = 2 To UBound(br)
        If Trim(br(i, 2)) <> "" Then
            d(Trim(br(i, 2))) = i
        End If
    Next i
    For i = 2 To UBound(ar)
        If Trim(ar(i, 2)) <> "" Then
            xh = d(Trim(ar(i, 2)))
            If xh <> "" Then
                ar(i, 5) = br(xh, 7)
                ar(i, 14) = br(xh, 1)
            End If
        End If
    Next i
    Set f = Nothing
    d.RemoveAll
    f = Dir(lj & "*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name And f <> "1.xlsx" Then
            Set wb = Workbooks.Open(lj & f, 0)
            lh = Val(Split(wb.Name, ".")(0)) + 4
            With wb.Worksheets(1)
                rs = .Cells(Rows.Count, 2).End(xlUp).Row
                br = .Range("a8:g" & rs)
            End With
            wb.Close False
            For i = 2 To UBound(br)
                If Trim(br(i, 1)) <> "" Then
                    d(Trim(br(i, 1))) = i
                End If
            Next i
            For i = 2 To UBound(ar)
                If Trim(ar(i, 14)) <> "" Then
                    xh = d(Trim(ar(i, 14)))
                    If xh <> "" Then
                        ar(i, lh) = br(xh, 7)
                    End If
                End If
            Next i
        End If
    f = Dir
    Loop
    .Range("a8:n" & r - 8) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

表格.rar (111.56 KB, 下载次数: 4)

2023-3-11 10:47 上传

点击文件名下载附件

3190496160

结果为核对，代码仅供参考，仅仅为你提供一个解决问题的思路，实在不行，可以加v

lxg315

3190496160 发表于 2023-3-11 10:47
结果为核对，代码仅供参考，仅仅为你提供一个解决问题的思路，实在不行，可以加v

了解，多谢您