BBS - Powered by Discuz! Board

标题: 应坛友水若善的需求，给大家一段VBA程序，正确匹配环境和事件 [打印本页]

作者: zhendeaini 时间: 2015-9-8 10:05 标题: 应坛友水若善的需求，给大家一段VBA程序，正确匹配环境和事件

前面章节我发布了《给大家演示<VBA制作工资条>》帖子，现在公布源代码（主体程序，代码完整，按顺序），有兴趣的童鞋自己组装下，看看是在哪里输入的（Sheet1还是Thisworkbook，是哪个事件触发的）：

程序代码1：
On Error Resume Next '当程序出错时候，继续执行下一句
'ActiveSheet.UsedRange.Select       '全选有效数据
Range("A1").CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).Weight = xlThin
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideHorizontal).Weight = xlThin

Dim a As Range, b%, c%, rowcount As Integer, rowblank As Integer, I, J, K As Integer
Set a = Application.InputBox("请选择相关区域（工资条表头）", "选取提示", , , , , , 8)
b = a.Rows.Count  '判断获取的工资条的标题的行数
rowblank = Application.InputBox("请输入需要插入的行数（空行>=0）", "提示", , , , , , 1)
rowcount = Application.CountA(Sheet1.Range("a:a")) - 1
Sheet1.Cells(2 + b, 1).Select '判断需要插入行数后定位
If rowblank < 0 Then    '当插入的空行小于0
  MsgBox "请输入至少为0的空行"
End If
If rowblank = 0 Then    '当插入的空行等于0，即从0开始
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For I = 1 To rowcount - 1
K = 2 + b + (rowblank + 1) * (I - 1)
  For J = 1 To rowblank
Rows(K).Select
Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
Next J
Next I
Sheet1.[A1].Select
For c = 1 To rowcount - 1 '开始复制标题
ActiveCell.Rows(1 & ":" & b).EntireRow.Select
ActiveCell.Offset(0, 2).Range("A1").Activate
Selection.Copy
ActiveCell.Offset(1 + b + rowblank, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Range("A1:A" & b).Select
Next c
End If
If rowblank > 0 Then       '当插入的空行大于0，即从1开始
Application.ScreenUpdating = False
For I = 1 To rowcount - 1
K = 2 + b + (rowblank + 1) * (I - 1)
  For J = 1 To rowblank
Rows(K).Select
Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
Next J
ActiveCell.Rows(1 & ":" & rowblank).EntireRow.Select
ActiveCell.Rows(1 & ":" & rowblank).EntireRow.RowHeight = 7 '设置间隔行的行高为7
Selection.Borders(xlEdgeLeft).LineStyle = xlNone  '去除边框
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.Offset(1 + rowblank + b, 0).Range("A1").Select
Next I
Sheet1.[A1].Select
For c = 1 To rowcount - 1 '开始复制标题
ActiveCell.Rows(1 & ":" & b).EntireRow.Select
ActiveCell.Offset(0, 2).Range("A1").Activate
Selection.Copy
ActiveCell.Offset(1 + b + rowblank, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown
ActiveCell.Range("A1:A" & b).Select
Next c
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = True

程序代码2：
Application.DisplayAlerts = False '关闭Excel的提示框
ThisWorkbook.Close savechanges:=True '保存文档
Application.CutCopyMode = False '关闭剪贴板提示

程序代码3：
Sheet1.Cells.Clear
Sheet1.Cells.RowHeight = 14.25
Sheet1.[A1].Select

以上每个代码程序都是一个独立完整的代码，对应的环境是不同的。看看谁最快组装好。

图片附件: VBA制作工资条.gif (2015-9-8 10:05, 1.75 MB) / 该附件被下载次数 24
http://hahabbs.w1.luyouxia.net/bbs/attachment.php?aid=136114

作者: 疾风一瞬 时间: 2015-9-8 10:35

虽不用但是顶[104]

作者: zhendeaini 时间: 2015-9-8 11:02

引用:

原帖由 疾风一瞬 于 2015-9-8 10:35 发表
虽不用但是顶[104]

有兴趣研究下！[0]

作者: 水若善 时间: 2015-9-11 16:30

我想系统内熟悉VBA的人其实不多，主要在征管负责电脑的几位高手吧。在征收一线和前台工作的同志广泛应用的是Excel，所以建议版主多讲解一下Excel的各个函数应用，不要一下讲太多，每次举实例讲一两个，335个函数够讲一段时间的了。

还有一个叫“按键精灵”的软件，对于执行一些机械重复的工作（实际工作中很多这种情况）相当有用，不妨研究一下。我见到高州有两位同志使用起来，真是事半功不知到几倍。[39]

作者: seaxin 时间: 2015-9-11 16:43

引用:

原帖由 水若善 于 2015-9-11 16:30 发表
我想系统内熟悉VBA的人其实不多，主要在征管负责电脑的几位高手吧。在征收一线和前台工作的同志广泛应用的是Excel，所以建议版主多讲解一下Excel的各个函数应用，不要一下讲太多，每次举实例讲一两个，335个函数够讲 ...

金三太垃圾，又卡慢，想用按键精灵都难

作者: 水若善 时间: 2015-9-14 10:08

引用:

原帖由 seaxin 于 2015-9-11 16:43 发表

金三太垃圾，又卡慢，想用按键精灵都难

新生事物会有完善和适应的过程　[8]

作者: zhendeaini 时间: 2015-9-22 16:26

引用:

原帖由 水若善 于 2015-9-11 16:30 发表
我想系统内熟悉VBA的人其实不多，主要在征管负责电脑的几位高手吧。在征收一线和前台工作的同志广泛应用的是Excel，所以建议版主多讲解一下Excel的各个函数应用，不要一下讲太多，每次举实例讲一两个，335个函数够讲 ...

前段时间我发布了《Excel知识兴趣点系列专题内容》，里边有常用函数的基础知识，有需要的可以自行下载学习。
送给大家一份特殊的新年礼物——Excel知识兴趣点系列专题内容：http://150.48.48.12/bbs/viewthread.php?tid=17321&extra=page%3D1
送给大家一份特殊的礼物——Excel知识兴趣点系列专题内容（完结篇）：http://150.48.48.12/bbs/viewthread.php?tid=18885&extra=page%3D1

欢迎光临 BBS (http://hahabbs.w1.luyouxia.net/bbs/)