执行VBA保留公式

youyukuku

    如何实现执行VBA代码汇总数据到表格后，保留excel表格里面的函数公式。

大灰狼1976

arr=range("a1:b1000").formula
数组里保存的是公式而不是值。
求助需要详细说明，带附件。

youyukuku

大灰狼1976 发表于 2024-2-1 11:57
arr=range("a1:b1000").formula
数组里保存的是公式而不是值。
求助需要详细说明，带附件。

附件已上传，帮忙看看。
实现执行“生成报表”后，表格中的公式保留。

大灰狼1976

youyukuku 发表于 2024-2-1 12:30
附件已上传，帮忙看看。
实现执行“生成报表”后，表格中的公式保留。

我上班时间不便下载附件，会有其他老师看的。

大灰狼1976

1. Option Explicit
   
2. 
   
3. Sub 生成报表()
   
4.     Dim arr, i&, n%, s$, x%, y%
   
5.     Dim d As Object, k, p, t As Date
   
6.     Rem  读取计算当月的最末日期
   
7.     With Sheet2
   
8.         t = DateSerial(.Range("H1").Value, .Range("I1").Value + 1, 0)
   
9.     End With
   
10.     Rem 读取打卡记录
    
11.     Set d = CreateObject("Scripting.Dictionary")
    
12.     arr = Sheet1.Range("A1").CurrentRegion.Value
    
13.     For i = 2 To UBound(arr)
    
14.         s = arr(i, 1) & "|" & arr(i, 2)
    
15.         If Not d.Exists(s) Then
    
16.             d(s) = i
    
17.         Else
    
18.             d(s) = d(s) & "|" & i
    
19.         End If
    
20.     Next
    
21.     Rem  整理打卡记录
    
22.     ReDim temp(1 To Day(t) * 2 + 2, 1 To d.Count * 2)
    
23.     For Each k In d.keys
    
24.         temp(1, x * 2 + 1) = Split(k, "|")(0) '工号
    
25.         temp(2, x * 2 + 1) = Split(k, "|")(1) '姓名
    
26.         For Each p In Split(d.Item(k), "|")
    
27.             y = Day(arr(Val(p), 3)) * 2 + 1
    
28.             If temp(y, x * 2 + 1) = "" Then
    
29.                 temp(y, x * 2 + 1) = Format(arr(Val(p), 3), "h:mm:ss")
    
30.             Else
    
31.                 temp(y + 1, x * 2 + 1) = Format(arr(Val(p), 3), "h:mm:ss")
    
32.             End If
    
33.         Next
    
34.         x = x + 1   '指针右移
    
35.     Next
    
36.     Rem 向汇总表写入记录
    
37.     Application.ScreenUpdating = False
    
38.     For i = 1 To d.Count
    
39.       Sheet2.Cells(2, i * 2).Resize(1000).ClearContents
    
40.       Sheet2.Cells(2, i * 2).Resize(UBound(temp)) = Application.Index(temp, , i * 2 - 1)
    
41.     Next i
    
42.     Application.ScreenUpdating = True
    
43.     Set d = Nothing
    
44. End Sub

复制代码

youyukuku

大灰狼1976 发表于 2024-2-1 19:29

测试之后运行正常，满足需求，
万分感谢！