[已解决]用VB6.0封装代码的问题

过江龙

请老师帮忙，看了几天的封装代码的几个列子，自己学将代码封装，怎么来出错。有哪位老师能否指点下，最好将VB6.0的源码放出来学习研究哈，谢谢！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-11-3 18:21

1. Dim xlApp As Excel.Application
   
2. 
   
3. Public Sub JL()
   
4.     Dim x%, y%
   
5.     Dim Name$, WBname$
   
6.     Dim i%, j%, k%
   
7.     Dim Danwei, Bianma, c, d, t
   
8.     Dim f As Long
   
9. 
   
10.     Set xlApp = GetObject(, "Excel.application")
    
11. 
    
12.     With xlApp
    
13.         WBname = .ActiveWorkbook.Name
    
14.         .Application.ScreenUpdating = False
    
15.         With .Application.FileDialog(1)
    
16.             .Title = "请选择要导入的Excel文件"
    
17.             If .Show = -1 Then
    
18.                 xlApp.Workbooks.Open .SelectedItems(1)
    
19.             Else
    
20.                 Exit Sub
    
21.             End If
    
22.         End With
    
23. 
    
24.         Name = .ActiveWorkbook.Name
    
25.         With .ActiveWorkbook.Worksheets(1)
    
26.             .Select
    
27.             .Copy Before:=xlApp.Workbooks(WBname).Worksheets(1)
    
28.         End With
    
29.         .Workbooks(Name).Close False
    
30. 
    
31.         With .Sheets(1)
    
32.             .Select
    
33.             .Name = "temp"
    
34.         End With
    
35. 
    
36.         With .Worksheets("预内资金")    'with sheet1
    
37.             i = .[A65536].End(xlUp).Row - 2
    
38.             .Range("A5:J" & i).ClearContents
    
39.             .Range("H" & i + 1).ClearContents
    
40.         End With
    
41. 
    
42.         With xlApp.Worksheets("专户资金")
    
43.             i = .[A65536].End(xlUp).Row - 2
    
44.             .Range("A5:J" & i).ClearContents
    
45.             .Range("H" & i + 1).ClearContents
    
46.         End With
    
47. 
    
48.         Danwei = .Application.InputBox("请输入申请单位：", "提示", "宜宾市翠屏区宗场镇中心小学校", , , , , 2)
    
49.         If Danwei = False Then
    
50.             删除temp表
    
51.             .Application.ScreenUpdating = True
    
52.             Exit Sub
    
53.         End If
    
54.         Bianma = .Application.InputBox("请输入单位编码：", "提示", 113757, , , , , 2)
    
55.         If Bianma = False Then
    
56.             删除temp表
    
57.             .Application.ScreenUpdating = True
    
58.             Exit Sub
    
59.         End If
    
60. 
    
61.         With .Worksheets("预内资金")
    
62.             .Range("A2") = "申请单位(盖章):" & Danwei & "           单位编码:" & Bianma & "           " & Format(Now, "yyyy""年""m""月""d""日""") & "            金额单位:元"
    
63.             xlApp.Worksheets("专户资金").Range("A2") = "申请单位(盖章):" & Danwei & "           单位编码:" & Bianma & "           " & Format(Now, "yyyy""年""m""月""d""日""") & "            金额单位:元"
    
64. 
    
65.             y = 5
    
66.             f = 5
    
67.             For Each c In xlApp.Range("D3:D" & xlApp.Range("D65536").End(xlUp).Row)
    
68.                 If Left(c, xlApp.Application.Search("-", c) - 1) <> "12" Then    'Left第一个起,Right最后一个起,Len文本个数
    
69.                     x = c.Row
    
70.                     .Cells(y, 1) = Left(xlApp.Cells(x, 5), xlApp.Application.Search("-", xlApp.Cells(x, 5)) - 1)
    
71.                     .Cells(y, 2) = Right(xlApp.Cells(x, 5), Len(xlApp.Cells(x, 5)) - xlApp.Application.Search("-", xlApp.Cells(x, 5)))
    
72.                     .Cells(y, 3) = Left(xlApp.Cells(x, 6), xlApp.Application.Search("-", xlApp.Cells(x, 6)) - 1)
    
73.                     .Cells(y, 4) = Right(xlApp.Cells(x, 6), Len(xlApp.Cells(x, 6)) - xlApp.Application.Search("-", xlApp.Cells(x, 6)))
    
74.                     .Cells(y, 5) = Right(xlApp.Cells(x, 4), Len(xlApp.Cells(x, 4)) - xlApp.Application.Search("-", xlApp.Cells(x, 4)))
    
75.                     .Cells(y, 6) = Right(xlApp.Cells(x, 11), Len(xlApp.Cells(x, 11)) - xlApp.Application.Search("-", xlApp.Cells(x, 11)))
    
76.                     .Cells(y, 7) = .Cells(y, 4)
    
77.                     .Cells(y, 8) = xlApp.Cells(x, 7)
    
78.                     y = y + 1
    
79.                     If .Cells(y, 1) = "合            计" Then
    
80.                         .Cells(y, 1).EntireRow.Insert
    
81.                     End If
    
82.                 Else
    
83.                     x = c.Row
    
84.                     xlApp.Worksheets("专户资金").Cells(f, 1) = Left(xlApp.Cells(x, 5), xlApp.Application.Search("-", xlApp.Cells(x, 5)) - 1)
    
85.                     xlApp.Worksheets("专户资金").Cells(f, 2) = Right(xlApp.Cells(x, 5), Len(xlApp.Cells(x, 5)) - xlApp.Application.Search("-", xlApp.Cells(x, 5)))
    
86.                     xlApp.Worksheets("专户资金").Cells(f, 3) = Left(xlApp.Cells(x, 6), xlApp.Application.Search("-", xlApp.Cells(x, 6)) - 1)
    
87.                     xlApp.Worksheets("专户资金").Cells(f, 4) = Right(xlApp.Cells(x, 6), Len(xlApp.Cells(x, 6)) - xlApp.Application.Search("-", xlApp.Cells(x, 6)))
    
88.                     xlApp.Worksheets("专户资金").Cells(f, 5) = Right(xlApp.Cells(x, 4), Len(xlApp.Cells(x, 4)) - xlApp.Application.Search("-", xlApp.Cells(x, 4)))
    
89.                     xlApp.Worksheets("专户资金").Cells(f, 6) = Right(xlApp.Cells(x, 11), Len(xlApp.Cells(x, 11)) - xlApp.Application.Search("-", xlApp.Cells(x, 11)))
    
90.                     xlApp.Worksheets("专户资金").Cells(f, 7) = xlApp.Worksheets("专户资金").Cells(f, 4)
    
91.                     xlApp.Worksheets("专户资金").Cells(f, 8) = xlApp.Cells(x, 7)
    
92.                     f = f + 1
    
93.                     If xlApp.Worksheets("专户资金").Cells(f, 1) = "合            计" Then
    
94.                         xlApp.Worksheets("专户资金").Cells(f, 1).EntireRow.Insert
    
95.                     End If
    
96.                 End If
    
97.             Next c
    
98.             For Each d In .Range("A5:A" & .[A65536].End(xlUp).Row)
    
99.                 If d = "合            计" Then
    
100.                     j = d.Row
     
101.                     .Cells(j, 8) = Application.Sum(.Range("H5:H" & j - 1))
     
102.                     If j > 16 Then
     
103.                         .Range("A16:A" & j).SpecialCells(4).Delete (3)
     
104.                     End If
     
105.                 End If
     
106.             Next d
     
107. 
     
108.             For Each t In xlApp.Worksheets("专户资金").Range("A5:A" & xlApp.Worksheets("专户资金").[A65536].End(xlUp).Row)
     
109.                 If t = "合            计" Then
     
110.                     k = t.Row
     
111.                     xlApp.Worksheets("专户资金").Cells(k, 8) = Application.Sum(xlApp.Worksheets("专户资金").Range("H5:H" & k - 1))
     
112.                     If k > 16 Then
     
113.                         xlApp.Worksheets("专户资金").Range("A16:A" & k).SpecialCells(4).Delete (3)
     
114.                     End If
     
115.                 End If
     
116.             Next t
     
117.         End With
     
118.         删除temp表
     
119.         Application.ScreenUpdating = True
     
120.     End With
     
121.     MsgBox "导入完成", vbInformation + vbOKOnly
     
122. 
     
123. End Sub
     
124. 
     
125. 
     
126. Private Sub 删除temp表()
     
127.     With xlApp
     
128.         .Application.DisplayAlerts = False    '屏弊删除提示
     
129.         .Sheets("temp").Delete
     
130.         .Application.DisplayAlerts = True
     
131.         .Worksheets("预内资金").Select
     
132.     End With
     
133. End Sub
     

复制代码

跳转到最佳答案楼层

过江龙

问题可能出在将VBA代码转换VB代码上。

hwc2ycy

校长的视频里很详细的嘛。

过江龙

是哪集哟？

hwc2ycy

楼主把在工作簿中原来没封装的VBA代码上传看看。

hwc2ycy

把要导入的数据测试文件也发上来一份。

hwc2ycy

你先保证未封装之前的VBA代码能正常工作。

leolee82

http://pan.baidu.com/s/1nCkET

过江龙

hwc2ycy 发表于 2013-11-3 11:17
你先保证未封装之前的VBA代码能正常工作。

这个能保证，已经在2003中运行了很多遍了，正常。请问老师，你能发一个校长这方面的视频吗？

过江龙

hwc2ycy 发表于 2013-11-3 11:06
楼主把在工作簿中原来没封装的VBA代码上传看看。

VBA代码：
Sub JL()
Dim x%, y%
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogOpen)
        .Title = "请选择要导入的Excel文件"
        If .Show = -1 Then
          Workbooks.Open .SelectedItems(1)
         Else
          Exit Sub
        End If
    End With
   
    Name = ActiveWorkbook.Name
    Sheets(1).Select
    Sheets(1).Copy Before:=Workbooks("预算拨款申请表.xls").Sheets(1)
    For Each wb In Workbooks
        If wb.Name = Name Then
            wb.Close False
        End If
    Next
    Sheets(1).Select
    Sheets(1).Name = "temp"
   
Sheets("temp").Select
With Sheet1
i = .[A65536].End(xlUp).Row - 2
.Range("A5:J" & i).ClearContents
.Range("H" & i + 1).ClearContents
i = Sheet2.[A65536].End(xlUp).Row - 2
Sheet2.Range("A5:J" & i).ClearContents
Sheet2.Range("H" & i + 1).ClearContents
danwei = Application.InputBox("请输入申请单位：", "提示", "宜宾市翠屏区宗场镇中心小学校", , , , , 2)
If danwei = False Then
删除temp表
Application.ScreenUpdating = True
Exit Sub
End If
bianma = Application.InputBox("请输入单位编码：", "提示", 113757, , , , , 2)
If bianma = False Then
删除temp表
Application.ScreenUpdating = True
Exit Sub
End If
.Range("A2") = "申请单位(盖章):" & danwei & "           单位编码:" & bianma & "           " & Application.WorksheetFunction.Text(Now, "yyyy""年""m""月""d""日""") & "            金额单位:元"
Sheet2.Range("A2") = "申请单位(盖章):" & danwei & "           单位编码:" & bianma & "           " & Application.WorksheetFunction.Text(Now, "yyyy""年""m""月""d""日""") & "            金额单位:元"

y = 5
f = 5
    For Each c In Range("D3:D" & [D65536].End(xlUp).Row)
        If Left(c, Application.Search("-", c) - 1) <> "12" Then 'Left第一个起,Right最后一个起,Len文本个数
            x = c.Row
             .Cells(y, 1) = Left(Cells(x, 5), Application.Search("-", Cells(x, 5)) - 1)
             .Cells(y, 2) = Right(Cells(x, 5), Len(Cells(x, 5)) - Application.Search("-", Cells(x, 5)))
             .Cells(y, 3) = Left(Cells(x, 6), Application.Search("-", Cells(x, 6)) - 1)
             .Cells(y, 4) = Right(Cells(x, 6), Len(Cells(x, 6)) - Application.Search("-", Cells(x, 6)))
             .Cells(y, 5) = Right(Cells(x, 4), Len(Cells(x, 4)) - Application.Search("-", Cells(x, 4)))
             .Cells(y, 6) = Right(Cells(x, 11), Len(Cells(x, 11)) - Application.Search("-", Cells(x, 11)))
             .Cells(y, 7) = .Cells(y, 4)
             .Cells(y, 8) = Cells(x, 7)
            y = y + 1
            If .Cells(y, 1) = "合            计" Then
            .Cells(y, 1).EntireRow.Insert
            End If
          Else
            x = c.Row
             Sheet2.Cells(f, 1) = Left(Cells(x, 5), Application.Search("-", Cells(x, 5)) - 1)
             Sheet2.Cells(f, 2) = Right(Cells(x, 5), Len(Cells(x, 5)) - Application.Search("-", Cells(x, 5)))
             Sheet2.Cells(f, 3) = Left(Cells(x, 6), Application.Search("-", Cells(x, 6)) - 1)
             Sheet2.Cells(f, 4) = Right(Cells(x, 6), Len(Cells(x, 6)) - Application.Search("-", Cells(x, 6)))
             Sheet2.Cells(f, 5) = Right(Cells(x, 4), Len(Cells(x, 4)) - Application.Search("-", Cells(x, 4)))
             Sheet2.Cells(f, 6) = Right(Cells(x, 11), Len(Cells(x, 11)) - Application.Search("-", Cells(x, 11)))
             Sheet2.Cells(f, 7) = Sheet2.Cells(f, 4)
             Sheet2.Cells(f, 8) = Cells(x, 7)
            f = f + 1
            If Sheet2.Cells(f, 1) = "合            计" Then
            Sheet2.Cells(f, 1).EntireRow.Insert
            End If
        End If
    Next c
    For Each d In .Range("A5:A" & .[A65536].End(xlUp).Row)
        If d = "合            计" Then
            j = d.Row
            .Cells(j, 8) = Application.Sum(.Range("H5:H" & j - 1))
            If j > 16 Then
             .Range("A16:A" & j).SpecialCells(4).Delete (3)
            End If
        End If
    Next d
   
    For Each t In Sheet2.Range("A5:A" & Sheet2.[A65536].End(xlUp).Row)
        If t = "合            计" Then
            k = t.Row
            Sheet2.Cells(k, 8) = Application.Sum(Sheet2.Range("H5:H" & k - 1))
            If k > 16 Then
             Sheet2.Range("A16:A" & k).SpecialCells(4).Delete (3)
            End If
        End If
    Next t
End With
删除temp表
Application.ScreenUpdating = True
End Sub


Sub 生成temp表()
    With Application.FileDialog(msoFileDialogOpen)
        .Title = "请选择要导入的Excel文件"
        If .Show = -1 Then
          Workbooks.Open .SelectedItems(1)
         Else
          Exit Sub
        End If
    End With
   
    Name = ActiveWorkbook.Name
    Sheets(1).Select
    Sheets(1).Copy Before:=Workbooks("预算拨款申请表.xls").Sheets(1)
    For Each wb In Workbooks
        If wb.Name = Name Then
            wb.Close False
        End If
    Next
    Sheets(1).Select
    Sheets(1).Name = "temp"
End Sub

Sub 删除temp表()
    Application.DisplayAlerts = False '屏弊删除提示
      Sheets("temp").Delete
    Application.DisplayAlerts = True
    Sheet1.Select
   
End Sub
要导入的文件：