BBS

  • 注册
  • 登录
  • 搜索
  • 标签
  • 帮助
BBS » 电脑、手机、平板知识专栏 » 应坛友水若善的需求,给大家一段VBA程序,正确匹配环境和事件 » 发表回复

预览帖子

游客


发表回复

用户名 游客 [会员登录]
  (可选)
  • Html 代码 可用
  • 表情 可用
  • Discuz!代码 可用
  • [img] 代码 可用
B I U | 字体 大小
| Align Left Align Center Align Right | Url Email Image | Quote Code
Rremove Format Unlink Undo Redo | Ordered List Unordered List Outdent Indent Float Left Float Right | Table Free Hide | flyflashmp3mtvmusicmusic2
flvmtv2music3
简单功能
  • 仿宋_GB2312
  • 黑体
  • 楷体_GB2312
  • 宋体
  • 新宋体
  • 微软雅黑
  • Trebuchet MS
  • Tahoma
  • Arial
  • Impact
  • Verdana
  • Times New Roman
  • 1
  • 2
  • 3
  • 4
  • 5
  • 6
  • 7
收缩编辑框扩展编辑框
上传附件 描述
文件尺寸: 小于 25000 kb
  [完成后可按 Ctrl+Enter 发布]    恢复数据

主题回顾

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

水若善 发表于 2015-9-14 10:08

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

金三太垃圾,又卡慢,想用按键精灵都难
新生事物会有完善和适应的过程 [8]

seaxin 发表于 2015-9-11 16:43

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

水若善 发表于 2015-9-11 16:30

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

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

zhendeaini 发表于 2015-9-8 11:02

引用:
原帖由 疾风一瞬 于 2015-9-8 10:35 发表
虽不用但是顶[104]
有兴趣研究下![0]

疾风一瞬 发表于 2015-9-8 10:35

虽不用但是顶[104]

zhendeaini 发表于 2015-9-8 10:05

前面章节我发布了《给大家演示<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


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

当前时区 GMT+8, 现在时间是 2026-4-4 00:05

清除 Cookies - 联系我们 - BBS - WAP - TOP - 界面风格

  • 默认风格
  • 喝彩奥运
  • 深邃永恒
  • 粉妆精灵
  • 诗意田园
  • 春意盎然
  • 黑色

Discuz!

Powered by Discuz! 6.0.0 © 2001-2007 Comsenz Inc.

Processed in 0.016179 second(s), 7 queries, Gzip enabled.