[已解决]原VBA能否帮忙用VB 封装 求完整程序代码 谢谢

lxjiang

Sub Macro1()
   Dim r%, i%, t%, m%
   Dim arr
   With Sheets("Cal")
        For m = 1 To 4
            r = .Cells(Rows.Count, 17 + m * 2).End(xlUp).Row
            arr = .Range(.Cells(4, 10), .Cells(r, 18 + m * 2))
            For i = 1 To UBound(arr)
              t = 0
              If Len(arr(i, 8 + m * 2)) > 0 And arr(i, 9 + m * 2) >= arr(i, 8 + m * 2) Then
                 For j = arr(i, 8 + m * 2) To arr(i, 9 + m * 2) Step 1
                   If Weekday(j, 2) Like "[" & arr(i, 1) & "]" Then
                    t = t + 1
                   End If
                 Next
                 arr(i, 5 + m) = t
              End If
            Next
            .Cells(4, 14 + m).Resize(UBound(arr), 1) = Application.Index(arr, 0, 5 + m)
            .Visible = False
        Next m
   End With
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-1-6 10:36

lxjiang 发表于 2014-1-6 10:13
谢谢 我尝试了 但是还是不行 初学 该需求工作中急用 请帮助 谢谢！

1. Public Sub Macro1()
   
2.     Dim r%, i%, t%, m%
   
3.     Dim arr
   
4.     Dim app As Object
   
5.     Set app = GetObject(, "excel.Application")
   
6.     With app.Worksheets("Cal")
   
7.         For m = 1 To 4
   
8.             r = .Cells(app.Rows.Count, 17 + m * 2).End(xlUp).Row
   
9.             arr = .Range(.Cells(4, 10), .Cells(r, 18 + m * 2))
   
10.             For i = 1 To UBound(arr)
    
11.                 t = 0
    
12.                 If Len(arr(i, 8 + m * 2)) > 0 And arr(i, 9 + m * 2) >= arr(i, 8 + m * 2) Then
    
13.                     For j = arr(i, 8 + m * 2) To arr(i, 9 + m * 2) Step 1
    
14.                         If Weekday(j, 2) Like "[" & arr(i, 1) & "]" Then
    
15.                             t = t + 1
    
16.                         End If
    
17.                     Next
    
18.                     arr(i, 5 + m) = t
    
19.                 End If
    
20.             Next
    
21.             .Cells(4, 14 + m).Resize(UBound(arr), 1) = app.Application.Index(arr, 0, 5 + m)
    
22.             .Visible = False
    
23.         Next m
    
24.     End With
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

这个可以封装的。

hwc2ycy

Excel VBA封装成dll的源码
http://www.excelpx.com/thread-238955-1-1.html

转：VB封装DLL实例讲解（一）
http://www.excelpx.com/thread-236047-1-1.html

lxjiang

hwc2ycy 发表于 2014-1-6 09:56
Excel VBA封装成dll的源码
http://www.excelpx.com/thread-238955-1-1.html

谢谢 我尝试了 但是还是不行 初学 该需求工作中急用 请帮助 谢谢！

hwc2ycy

lxjiang 发表于 2014-1-6 10:13
谢谢 我尝试了 但是还是不行 初学 该需求工作中急用 请帮助 谢谢！

1. Public Sub Macro1()
   
2.     Dim r%, i%, t%, m%
   
3.     Dim arr
   
4.     Dim app As Object
   
5.     Set app = GetObject(, "excel.Application")
   
6.     With app.Worksheets("Cal")
   
7.         For m = 1 To 4
   
8.             r = .Cells(app.Rows.Count, 17 + m * 2).End(xlUp).Row
   
9.             arr = .Range(.Cells(4, 10), .Cells(r, 18 + m * 2))
   
10.             For i = 1 To UBound(arr)
    
11.                 t = 0
    
12.                 If Len(arr(i, 8 + m * 2)) > 0 And arr(i, 9 + m * 2) >= arr(i, 8 + m * 2) Then
    
13.                     For j = arr(i, 8 + m * 2) To arr(i, 9 + m * 2) Step 1
    
14.                         If Weekday(j, 2) Like "[" & arr(i, 1) & "]" Then
    
15.                             t = t + 1
    
16.                         End If
    
17.                     Next
    
18.                     arr(i, 5 + m) = t
    
19.                 End If
    
20.             Next
    
21.             .Cells(4, 14 + m).Resize(UBound(arr), 1) = app.Application.Index(arr, 0, 5 + m)
    
22.             .Visible = False
    
23.         Next m
    
24.     End With
    
25. End Sub
    

复制代码

hwc2ycy

你要自己添加引用
工作簿中的代码。

1. Sub Macro1()
   
2.     Dim app As MyProject.Class1
   
3.     Set app = New MyProject.Class1
   
4.     app.Macro1
   
5. End Sub

复制代码

hwc2ycy

MyProject.rar (4.79 KB, 下载次数: 3)

2014-1-6 10:41 上传

点击文件名下载附件
这是我这里生成的DLL文件。

hwc2ycy

在VB中要自己添加这两个引用，版本根据你安装的来选。
我这是用的2010的。

hwc2ycy

在VBA中添加引用的画面。

hwc2ycy

封装.rar (8.38 KB, 下载次数: 8)

2014-1-6 10:49 上传

点击文件名下载附件
我这的VB工程打包。