设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 用VB6.0封装代码的问题
数据透视表40+个常用小技巧，让你一次学会！
123下一页
返回列表 发新帖
楼主: 过江龙

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

[复制链接]
 楼主| 发表于 2013-11-3 15:29 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
学习了一上午，终于整好了，VB6.0源代码放出，请老师们优化。
Sub hongtong()
   Dim XLAPP As Object
   Set XLAPP = GetObject(, "Excel.Application")
XLAPP.ScreenUpdating = False
   Dim x%, y%
With XLAPP.FileDialog(msoFileDialogOpen)
        .Title = "请选择从大平台中导出的Excel文件申报计划"
        If .Show = -1 Then
           XLAPP.Workbooks.Open .SelectedItems(1)
         Else
          XLAPP.ScreenUpdating = True
          Exit Sub
        End If
    End With
   
    Name = XLAPP.ActiveWorkbook.Name
    XLAPP.Sheets(1).Select
   XLAPP.Sheets(1).Copy Before:=XLAPP.Workbooks("预算拨款申请表.xls").Sheets(1)
    For Each wb In XLAPP.Workbooks
        If wb.Name = Name Then
            wb.Close False
        End If
    Next
    XLAPP.Sheets(1).Select
    XLAPP.Sheets(1).Name = "temp"
   
XLAPP.Sheets("temp").Select
With XLAPP.Sheets("预内资金")
i = .[A65536].End(xlUp).Row - 2
.Range("A5:J" & i).ClearContents
.Range("H" & i + 1).ClearContents
i = XLAPP.Sheets("专户资金").[A65536].End(xlUp).Row - 2
XLAPP.Sheets("专户资金").Range("A5:J" & i).ClearContents
XLAPP.Sheets("专户资金").Range("H" & i + 1).ClearContents

danwei = XLAPP.InputBox("请输入申请单位：", "提示", "宜宾市翠屏区宗场镇中心小学校", , , , , 2)
If danwei = False Then
    XLAPP.DisplayAlerts = False '屏弊删除提示
      XLAPP.Sheets("temp").Delete
    XLAPP.DisplayAlerts = True
    XLAPP.Sheets("预内资金").Select
    XLAPP.ScreenUpdating = True
Exit Sub
End If
bianma = XLAPP.InputBox("请输入单位编码：", "提示", 113757, , , , , 2)
If bianma = False Then
    XLAPP.DisplayAlerts = False '屏弊删除提示
      XLAPP.Sheets("temp").Delete
    XLAPP.DisplayAlerts = True
    XLAPP.Sheets("预内资金").Select
    XLAPP.ScreenUpdating = True
Exit Sub
End If
.Range("A2") = "申请单位(盖章):" & danwei & "           单位编码:" & bianma & "           " & XLAPP.WorksheetFunction.Text(Now, "yyyy""年""m""月""d""日""") & "            金额单位:元"
XLAPP.Sheets("专户资金").Range("A2") = "申请单位(盖章):" & danwei & "           单位编码:" & bianma & "           " & XLAPP.WorksheetFunction.Text(Now, "yyyy""年""m""月""d""日""") & "            金额单位:元"



y = 5
f = 5
    For Each c In XLAPP.Sheets("temp").Range("D3:D" & XLAPP.Sheets("temp").[D65536].End(xlUp).Row)
        If Left(c, XLAPP.Search("-", c) - 1) <> "12" Then 'Left第一个起,Right最后一个起,Len文本个数
            x = c.Row
             .Cells(y, 1) = Left(XLAPP.Sheets("temp").Cells(x, 5), XLAPP.Search("-", XLAPP.Sheets("temp").Cells(x, 5)) - 1)
             .Cells(y, 2) = Right(XLAPP.Sheets("temp").Cells(x, 5), Len(XLAPP.Sheets("temp").Cells(x, 5)) - XLAPP.Search("-", XLAPP.Sheets("temp").Cells(x, 5)))
             .Cells(y, 3) = Left(XLAPP.Sheets("temp").Cells(x, 6), XLAPP.Search("-", XLAPP.Sheets("temp").Cells(x, 6)) - 1)
             .Cells(y, 4) = Right(XLAPP.Sheets("temp").Cells(x, 6), Len(XLAPP.Sheets("temp").Cells(x, 6)) - XLAPP.Search("-", XLAPP.Sheets("temp").Cells(x, 6)))
             .Cells(y, 5) = Right(XLAPP.Sheets("temp").Cells(x, 4), Len(XLAPP.Sheets("temp").Cells(x, 4)) - XLAPP.Search("-", XLAPP.Sheets("temp").Cells(x, 4)))
             .Cells(y, 6) = Right(XLAPP.Sheets("temp").Cells(x, 11), Len(XLAPP.Sheets("temp").Cells(x, 11)) - XLAPP.Search("-", XLAPP.Sheets("temp").Cells(x, 11)))
             .Cells(y, 7) = .Cells(y, 4)
             .Cells(y, 8) = XLAPP.Cells(x, 7)
            y = y + 1
            If .Cells(y, 1) = "合            计" Then
            .Cells(y, 1).EntireRow.Insert
            End If
          Else
            x = c.Row
             XLAPP.Sheets("专户资金").Cells(f, 1) = Left(XLAPP.Cells(x, 5), XLAPP.Search("-", XLAPP.Cells(x, 5)) - 1)
             XLAPP.Sheets("专户资金").Cells(f, 2) = Right(XLAPP.Cells(x, 5), Len(XLAPP.Cells(x, 5)) - XLAPP.Search("-", XLAPP.Cells(x, 5)))
             XLAPP.Sheets("专户资金").Cells(f, 3) = Left(XLAPP.Cells(x, 6), Application.Search("-", XLAPP.Cells(x, 6)) - 1)
             XLAPP.Sheets("专户资金").Cells(f, 4) = Right(XLAPP.Cells(x, 6), Len(XLAPP.Cells(x, 6)) - XLAPP.Search("-", XLAPP.Cells(x, 6)))
             XLAPP.Sheets("专户资金").Cells(f, 5) = Right(XLAPP.Cells(x, 4), Len(XLAPP.Cells(x, 4)) - XLAPP.Search("-", XLAPP.Cells(x, 4)))
             XLAPP.Sheets("专户资金").Cells(f, 6) = Right(XLAPP.Cells(x, 11), Len(XLAPP.Cells(x, 11)) - XLAPP.Search("-", XLAPP.Cells(x, 11)))
             XLAPP.Sheets("专户资金").Cells(f, 7) = XLAPP.Sheets("专户资金").Cells(f, 4)
             XLAPP.Sheets("专户资金").Cells(f, 8) = XLAPP.Cells(x, 7)
            f = f + 1
            If XLAPP.Sheets("专户资金").Cells(f, 1) = "合            计" Then
            XLAPP.Sheets("专户资金").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) = XLAPP.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 XLAPP.Sheets("专户资金").Range("A5:A" & XLAPP.Sheets("专户资金").[A65536].End(xlUp).Row)
        If t = "合            计" Then
            k = t.Row
            XLAPP.Sheets("专户资金").Cells(k, 8) = XLAPP.Sum(XLAPP.Sheets("专户资金").Range("H5:H" & k - 1))
            If k > 16 Then
             XLAPP.Sheets("专户资金").Range("A16:A" & k).SpecialCells(4).Delete (3)
            End If
        End If
    Next t
End With
    XLAPP.DisplayAlerts = False '屏弊删除提示
      XLAPP.Sheets("temp").Delete
   XLAPP.DisplayAlerts = True
    XLAPP.Sheets("预内资金").Select
    XLAPP.ScreenUpdating = True
End Sub
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hwc2ycy
发表于 2013-11-3 18:21 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Dim xlApp As Excel.Application

  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

  10.     Set xlApp = GetObject(, "Excel.application")

  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

  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

  31.         With .Sheets(1)
  32.             .Select
  33.             .Name = "temp"
  34.         End With

  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

  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

  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

  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""日""") & "            金额单位:元"

  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

  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

  123. End Sub


  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
复制代码
回复

使用道具 举报

hwc2ycy
发表于 2013-11-3 18:22 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
最好用数组吧，一次读取。

回复

使用道具 举报

hwc2ycy
发表于 2013-11-3 18:23 | 显示全部楼层
另外，能用VBA函数的情况下尽量用VBA的函数，象search就可以用instr来代替，text用format
回复

使用道具 举报

发表于 2013-11-3 19:14 | 显示全部楼层
在VB6里面，打开你的工程，

然后照下面的操作进行调试

运行你的工程，在弹出来的 工程属性窗口中》调试 》启动工程时》选择等待创建部件
点确定

其实按了F5 弹出来的窗口直接点确定就行了

接下来，在你的工作薄里面写代码
你可以引用（每次按下F5都需要重新引用） ，也可以创建

以你附件里的来说吧，你是引用的，过程写好以后，就可以直接用F8进行测试了，
会自动跳转到VB里面去的，你就和平时在工作薄里那样调试找问题就行了
回复

使用道具 举报

 楼主| 发表于 2013-11-4 08:44 | 显示全部楼层
hwc2ycy 发表于 2013-11-3 18:22
最好用数组吧，一次读取。

数组当然好，能提高运行速度。但我对数组不熟悉，请老师帮我优化，也好学习下，感谢！！
回复

使用道具 举报

hwc2ycy
发表于 2013-11-4 09:05 | 显示全部楼层
过江龙 发表于 2013-11-4 08:44
数组当然好，能提高运行速度。但我对数组不熟悉，请老师帮我优化，也好学习下，感谢！！

数组又不难，比封装学起来容易多了。

【VBA字典数组201301班】第一讲 课件
http://www.excelpx.com/thread-312398-1-1.html

这是数组的课件，你自己学习下嘛。
回复

使用道具 举报

hwc2ycy
发表于 2013-11-4 09:07 | 显示全部楼层
用了数组，复制工作表，重命名TEMP，删除这些操作都不需要了。
回复

使用道具 举报

发表于 2013-11-4 09:39 | 显示全部楼层
过江龙 发表于 2013-11-3 11:48
VBA代码：
Sub JL()
Dim x%, y%

太牛了，学习下
回复

使用道具 举报

hhzjxss
发表于 2013-11-4 13:24 | 显示全部楼层
不错，整上封装了，不过这个也只是玩玩而以，没大的必要哦！
回复

使用道具 举报

下一页 »
123下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-6 17:33 , Processed in 0.334702 second(s), 8 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表