帮忙写个汇总的(实在搞不定- -!)

zhurq9876

要实现的效果如下：所有汇总数据以链接格式粘贴

汇总:把D、E、F、G、J、K、N、O列的数据全部汇总

另外再帮忙写一个纯审定区域汇总，既G、K、O列,
要先匹配D或者E列的名称是否一致，另外如果审定与送审值有变动的，填充颜色。
并把文件名称写入对应的R列
PS:好人一生平安

liulang0808

遍历汇总，论坛很多案例，楼主检索参考下
再有问题具体咨询吧

zhurq9876

liulang0808 发表于 2021-10-26 07:40
遍历汇总，论坛很多案例，楼主检索参考下
再有问题具体咨询吧

Sub huizong()
    Dim arr, n As Byte, i As Integer, wk
    Application.ScreenUpdating = False
    ChDrive Mid(ThisWorkbook.Path, 1, 1)
    ChDir ThisWorkbook.Path
    arr = Application.GetOpenFilename(, , , , True)
    If IsArray(arr) = False Then Exit Sub
    i = 3
    For n = 1 To UBound(arr)
        i = i + 1
        Set wk = Workbooks.Open(arr(n))
        With ThisWorkbook.Sheets("汇总")
         ThisWorkbook.Sheets("汇总").Cells(i, 4) = Sheets("单项清单").Range("d4")
         .Cells(i, 5) = Sheets("单项清单").Range("e4")
         .Cells(i, 6) = Sheets("单项清单").Range("f4")
         .Cells(i, 7) = Sheets("单项清单").Range("g4")
         .Cells(i, 10) = Sheets("单项清单").Range("j4")
         .Cells(i, 11) = Sheets("单项清单").Range("k4")
         .Cells(i, 14) = Sheets("单项清单").Range("n4")
         .Cells(i, 15) = Sheets("单项清单").Range("o4")
        End With
        wk.Close 0
        Set wk = Nothing
    Next n
    Application.ScreenUpdating = True
End Sub

zhurq9876

Sub huizong()
    Dim arr, n As Byte, i As Integer, wk
    Application.ScreenUpdating = False
    ChDrive Mid(ThisWorkbook.Path, 1, 1)
    ChDir ThisWorkbook.Path
    arr = Application.GetOpenFilename(, , , , True)
    If IsArray(arr) = False Then Exit Sub
    i = 3
    For n = 1 To UBound(arr)
        i = i + 1
        Set wk = Workbooks.Open(arr(n))
        With ThisWorkbook.Sheets("汇总")
         ThisWorkbook.Sheets("汇总").Cells(i, 4) = Sheets("单项清单").Range("d4")
         .Cells(i, 5) = Sheets("单项清单").Range("e4")
         .Cells(i, 6) = Sheets("单项清单").Range("f4")
         .Cells(i, 7) = Sheets("单项清单").Range("g4")
         .Cells(i, 10) = Sheets("单项清单").Range("j4")
         .Cells(i, 11) = Sheets("单项清单").Range("k4")
         .Cells(i, 14) = Sheets("单项清单").Range("n4")
         .Cells(i, 15) = Sheets("单项清单").Range("o4")
        End With
        wk.Close 0
        Set wk = Nothing
    Next n
    Application.ScreenUpdating = True
End Sub

咋修改为粘贴链接,另外判断名字是否一致要咋加上去

zhurq9876

liulang0808 发表于 2021-10-26 07:40
遍历汇总，论坛很多案例，楼主检索参考下
再有问题具体咨询吧

版主，

1. 
   
2. Sub sjhz()
   
3.     Dim arr, n As Byte, i As Integer, wk
   
4.     Application.ScreenUpdating = False
   
5.     ChDrive Mid(ThisWorkbook.Path, 1, 1)
   
6.     ChDir ThisWorkbook.Path
   
7.     arr = Application.GetOpenFilename(, , , , True)
   
8.     If IsArray(arr) = False Then Exit Sub
   
9.     i = 3
   
10.     For n = 1 To UBound(arr)
    
11.         i = i + 1
    
12.         Set wk = Workbooks.Open(arr(n))
    
13. 
    
14.         With ThisWorkbook.Sheets("汇总")
    
15.                 If Len(ThisWorkbook.Sheets("汇总").Cells(i, 4)) > 0 And ThisWorkbook.Sheets("汇总").Cells(i, 5) = wk.Sheets("单项清单").Range("e4") Then
    
16.           wk.Sheets("单项清单").Range("g4").Copy
    
17.           Application.Goto ThisWorkbook.Sheets("汇总").Cells(i, 7)
    
18.           ActiveSheet.Paste Link:=True
    
19.                    wk.Sheets("单项清单").Range("k4").Copy
    
20.           Application.Goto ThisWorkbook.Sheets("汇总").Cells(i, 11)
    
21.           ActiveSheet.Paste Link:=True
    
22.                    wk.Sheets("单项清单").Range("o4").Copy
    
23.           Application.Goto ThisWorkbook.Sheets("汇总").Cells(i, 15)
    
24.           ActiveSheet.Paste Link:=True
    
25. End If
    
26.         End With
    
27.         wk.Close 0
    
28.         Set wk = Nothing
    
29.     Next n
    
30.     Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

这一句是判断第四列单元格名称是否一致，但是只能在遍历文件顺序完全一样的情况下才有效，如何改成如果名称不一致，则跳到下一行单元格比较。
If Len(ThisWorkbook.Sheets("汇总").Cells(i, 4)) > 0 And ThisWorkbook.Sheets("汇总").Cells(i, 5) = wk.Sheets("单项清单").Range("e4") Then