用宏实现数据汇总，将分计划里的计划时间。填入到总计划对应的位置里

zzq657266102

求大哥们，附件有文件。
通过相同的制号和件号内容，将分计划里计划时间和实际时间。填入总计划里对应sheet页的对应件号的计划时间和实际时间里

quqiyuan

参与一下，供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet, p$, f$, arr, brr
    Set wb = ThisWorkbook
    p = wb.Path & "\"
    f = Dir(p & "分计划.xlsx")
    If f <> "" Then
        With Workbooks.Open(p & "分计划.xlsx", 0).Sheets("本体")
            arr = .UsedRange.Value
            .Parent.Close 0
        End With
    End If
    For Each sht In wb.Sheets
        With sht
            brr = .UsedRange.Value
            .UsedRange.ClearContents
            For i = 2 To UBound(arr)
                If arr(i, 2) <> Empty Then
                    If arr(i, 2) = sht.Name Then
                        For j = 1 To UBound(brr)
                            For k = 1 To UBound(brr, 2)
                                If brr(j, k) = arr(i, 3) Then
                                    brr(j, k + 1) = arr(i, 1)
                                    brr(j, k + 2) = arr(i, 6)
                                End If
                            Next
                        Next
                    End If
                End If
            Next
        .UsedRange.Value = brr
        End With
    Next
    Beep
End Sub

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, i&, j&, strFileName$, strPath$, dic As Object, strKey$, rngFind As Range
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "总计划.xlsx"
   
    If Dir(strFileName) = "" Then MsgBox "总计划文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [B5].CurrentRegion.Value
   
    For i = 2 To UBound(ar)
        strKey = ar(i, 2) & "|" & ar(i, 3)
        dic(strKey) = Array(ar(i, 1), ar(i, 6), ar(i, 5))
    Next i
   
    With Workbooks.Open(strFileName, 0)
        For j = 0 To dic.Count - 1
            br = Split(dic.keys()(j), "|")
            On Error Resume Next
               With Worksheets(br(0))
                   Set rngFind = .Cells.Find(br(1), , , xlWhole)
                   If Not rngFind Is Nothing Then rngFind.Offset(, 1).Resize(, 3).Value = dic.Items()(j)
               End With
            On Error GoTo 0
        Next j
        .Close True
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.24
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set ws = ThisWorkbook
   
5.     Set sh = ws.Sheets("主页")
   
6.     With Application.FileDialog(msoFileDialogFilePicker)
   
7.         .InitialFileName = ThisWorkbook.Path & ""
   
8.         .Title = "请选择对应Excel文件"
   
9.         .AllowMultiSelect = False
   
10.         .Filters.Clear
    
11.         .Filters.Add "Excel文件", "*.xls*"
    
12.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
13.     End With
    
14.     Set wb = Workbooks.Open(f, 0)
    
15.     With wb.Sheets(1)
    
16.         Set Rng = .UsedRange.Find("件号")
    
17.         c = Rng.Column: r1 = Rng.Row
    
18.         r = .Cells(Rows.Count, c).End(3).Row
    
19.         For i = r1 + 1 To r
    
20.             s = .Cells(i, c - 1).Value & "|" & .Cells(i, c).Value
    
21.             d(s) = Array(.Cells(i, c - 2).Value, .Cells(i, c + 3).Value)
    
22.         Next
    
23.     End With
    
24.     wb.Close 0
    
25.     b = [{3,10}]
    
26.     With ws
    
27.         For Each sht In .Sheets
    
28.             If sht.Name <> sh.Name Then
    
29.                 With sht
    
30.                     Set Rng = .UsedRange.Find("件号")
    
31.                     r1 = Rng.Row
    
32.                     r = .Cells(Rows.Count, 1).End(3).Row
    
33.                     For x = 1 To UBound(b)
    
34.                         For i = r1 + 1 To r
    
35.                             s = .Name & "|" & .Cells(i, b(x))
    
36.                             If s <> Empty Then
    
37.                                 If d.exists(s) Then
    
38.                                     .Cells(i, b(x) + 1) = d(s)(0)
    
39.                                     .Cells(i, b(x) + 2) = d(s)(1)
    
40.                                 End If
    
41.                             End If
    
42.                         Next
    
43.                     Next
    
44.                 End With
    
45.             End If
    
46.         Next
    
47.     End With
    
48.     Set d = Nothing
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    

复制代码

gwjkkkkk

。。。。。。。。。。

zzq657266102

gwjkkkkk 发表于 2024-7-24 19:54
。。。。。。。。。。

太牛逼了

zzq657266102

ykcbf1100 发表于 2024-7-24 19:53
参与一下。。。

谢谢您的帮助，打开了新世界的大门