自动将《明细》表C、E、F三列的资料组合并去除重复填写在《图片》表A列，同时《图...

1AAAAA

挺复杂的需求，求高手帮忙解结

自动将《明细》表C、E、F三列的资料组合并去除重复填写在《图片》表A列，同时《图片》表B列跟据A列的资料抽取出《产品表》对应的图片

1AAAAA

这个是没有密码的资料，请大神看一下怎么做

3190496160

产品表 有打开密码

1AAAAA

3190496160 发表于 2020-3-24 20:48
产品表 有打开密码

更新了资料表，请大神帮忙

1AAAAA

3190496160 发表于 2020-3-24 20:48
产品表 有打开密码

求高手帮忙，我才学三天，更新资料了

3190496160

Sub test()
Set d = CreateObject("scripting.dictionary")
With Sheets("明细")
    r = .Cells(Rows.Count, 4).End(xlUp).Row
    ar = .Range("d1:f" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" And Trim(ar(i, 3)) <> "" Then
        s = Trim(ar(i, 1)) & Trim(ar(i, 2)) & Trim(ar(i, 3))
        d(s) = ""
    End If
Next i
With Sheets("图片")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("a2:a" & rs) = Empty
    .[a2].Resize(d.Count, 1) = Application.Transpose(d.keys)
End With
End Sub

魂断蓝桥

Option Explicit
Sub a()
    Dim arr, d, s$, i%, k
    'Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    arr = Sheet3.[d1].CurrentRegion
    For i = 2 To UBound(arr)
        s = arr(i, 1) & arr(i, 2) & arr(i, 3)
        d(s) = ""
    Next
    Sheet1.Activate
    [a2:a999] = ""
    k = d.keys
    [a2].Resize(d.Count, 1) = Application.Transpose(k)
    Set d = Nothing
    Call b
    'Application.ScreenUpdating = True
End Sub
Sub b()
    Dim myf, arr, i%, wb As Workbook, ran As Range, r%
    Dim myw, myh, myl, myt, mysha
    For Each mysha In Sheet1.Shapes
        If mysha.Type = 13 Then mysha.Delete
    Next
    myw = [b2].Width
    myh = [b2].Height
    arr = [a2].CurrentRegion
    myf = ActiveWorkbook.Path & "\产品表.xlsx"
    Set wb = Workbooks.Open(myf)
    With wb.Sheets(1)
        For i = 1 To UBound(arr)
            Set ran = .Range("a:a").Find(arr(i, 1), , , 1)
            If Not ran Is Nothing Then
                r = ran.Row
                .Shapes("图片 " & r).Copy
                ThisWorkbook.Sheets("图片").Activate
                Cells(i + 1, 2).Select
                myl = ActiveCell.Left
                myt = ActiveCell.Top
                ActiveSheet.Paste
                With Selection.ShapeRange
                    .LockAspectRatio = msoFalse
                    .Width = myw - 5
                    .Height = myh - 5
                    .Left = myl + 2
                    .Top = myt + 2
                End With
            End If
        Next
    End With
    wb.Close 0
End Sub

1AAAAA

魂断蓝桥 发表于 2020-3-26 15:06
Option Explicit
Sub a()
    Dim arr, d, s$, i%, k

大神，你好，很感谢你的帮助，但你的代码有一点点问题，不出结果，我不会修改，我才学了三天

1AAAAA

魂断蓝桥 发表于 2020-3-26 15:06
Option Explicit
Sub a()
    Dim arr, d, s$, i%, k

图片抽不出，只出了最后一张

魂断蓝桥

1AAAAA 发表于 2020-3-26 15:54
图片抽不出，只出了最后一张

我也不知道什么原因，点击两次就可以了。