我编写的VBA程序

Sub 删除空格() Dim i% For i = 1 To 10 Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, MatchByte:=False Next i End Sub Sub 删除工作簿中所有 表 关于同志近三年现实表现材料材料类招标技术评分表图表与交易pdf视力表打印pdf用图表说话 pdf 中的空格() Dim i% Dim j As Integer For j = 1 To Worksheets.Count Worksheets(j).Select For i = 1 To 10 Cells.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, MatchByte:=False Next i Next j End Sub Sub 比较两列数据不同之处() ' ' 比较两列数据不同之处 Macro ' 宏由 罗艳军 录制，时间: 2009-9-18 ' Dim hs As Integer Dim i As Integer hs = Range("a65536").End(xlUp).Row For i = 1 To hs If Range("A" & i).Value <> Range("B" & i).Value Then MsgBox "注意第" & i & "行数据不同" Exit Sub End If Next i MsgBox "现在两列数据完全相同" End Sub Sub 在A列中查找B列没有的数据() ' 宏由 罗艳军 录制，时间: 2009-10-1 Dim hs As Integer Dim i As Integer hs = Range("a65536").End(xlUp).Row For i = 1 To hs 'Debug.Print i If Columns("B").Find(Range("A" & i).Value) Is Nothing Then MsgBox "注意，没有" & "A" & i Exit Sub Else End If Next i MsgBox "现在A列有的数据B列中全有了！" End Sub Sub 合并两列数据() '使用本程序前，请把光标停在第二列的第一行 Do While ActiveCell <> "" ' 一直循环，直到活动单元格为空。 ActiveCell.Offset(0, 1).FormulaR1C1 = _ ActiveCell.Offset(0, -1) & ActiveCell.Offset(0, 0) ActiveCell.Offset(1, 0).Select Loop End Sub Sub 区域兑换() Dim XR As Range, YR As Range Dim SZ1, SZ2, Down If Selection.Areas.Count = 2 Then Set XR = Selection.Areas(1) Set YR = Selection.Areas(2) If Not Intersect(XR, YR) Is Nothing Then Down = MsgBox(" 选择区域有重叠！" & vbCrLf & _ "对换后数据将有部份被覆盖！" & vbCrLf & _ " 是否继续？", vbYesNo) If Down = vbNo Then Exit Sub End If If XR.Rows.Count = YR.Rows.Count And XR.Columns.Count = YR.Columns.Count Then SZ1 = XR.Formula SZ2 = YR.Formula XR = SZ2 YR = SZ1 Else MsgBox "选择的两个区域不相同！" End If Else MsgBox "请选择二个相同的区域！" End If End Sub Sub 把A列中有而B列中没有的数据挑出来放在C列中() ' 宏由 罗艳军 录制，时间: 2010-8-26 Dim hs As Integer Dim i As Integer Dim c As Integer c = 1 hs = Range("a65536").End(xlUp).Row For i = 1 To hs 'Debug.Print i If Columns("B").Find(Range("A" & i).Value) Is Nothing Then Range("c" & c).Value = Range("A" & i).Value c = c + 1 End If Next i MsgBox "现在A列有的数据B列中全有了！" End Sub ‘用数组分班 Option Base 1 Sub Macro2() ' Macro2 Macro ' 宏由 罗艳军 录制，时间: 2010-9-15 '初始化 Dim xsrs As Integer xsrs = 298 Dim bjs As Integer Dim xssz(298, 9) bjs = 6 'xssz = Sheet1.Range("A2:G299") '工作表数据到数组 For i = 1 To 298 For j = 1 To 7 xssz(i, j) = Cells(i + 1, j) Next j Next i '数组求和 For i = 1 To xsrs xssz(i, 8) = xssz(i, 2) + xssz(i, 3) + xssz(i, 4) + xssz(i, 5) + xssz(i, 6) + xssz(i, 7) Next '数组排序 Dim ls(8) For i = 1 To xsrs For j = i + 1 To xsrs If xssz(i, 8) < xssz(j, 8) Then For z = 1 To 8 ls(z) = xssz(i, z) xssz(i, z) = xssz(j, z) xssz(j, z) = ls(z) Next End If Next Next '分班 For i = 1 To bjs Sheets.Add ActiveSheet.Name = "高一" & i For j = 1 To 50 For k = 1 To 8 If i * 50 - 50 + j > xsrs Then Exit Sub End If Cells(j, k) = xssz(i * 50 - 50 + j, k) Next k Next j Next i End Sub '冒泡法直接排序，没用到数组 '罗艳军 2009年10月于枣阳 Private Sub CommandButton1_Click() Dim tem For i = 1 To 25 For j = i + 1 To 25 If Range("a" & i) < Range("a" & j) Then tem = Range("a" & i) Range("a" & i) = Range("a" & j) Range("a" & j) = tem End If '下面两行是延时程序，看清冒泡的过程 'For z = 1 To 5000000 'Next z Next j Next i End Sub Private Sub CommandButton2_Click() Dim arr, tem arr = Range("a1:a25") For i = 1 To 25 For j = i + 1 To 25 If arr(i, 1) < arr(j, 1) Then tem = arr(i, 1) arr(i, 1) = arr(j, 1) arr(j, 1) = tem End If Next j Next i Range("a1:a25") = arr End Sub Sub 检查错的名字() ' ' 程序由罗艳军开发，时间: 2011-10-1 ' Dim i As Integer Dim j As Integer Dim hs As Integer For i = 2 To Worksheets.Count 'Debug.Print Worksheets(i).Name Worksheets(i).Activate hs = Range("a65536").End(xlUp).Row For j = 2 To hs If Sheet1.Columns("A").Find(Range("A" & j).Value) Is Nothing Then Range("A" & j).Select With Selection.Interior .ColorIndex = 7 .Pattern = xlSolid End With MsgBox "注意,此人名字有误:" & Range("A" & j).Value Exit Sub End If Next j Next i MsgBox "所有人的名字都正确!" End Sub Sub 工资汇总() Dim i As Integer Dim j As Integer Dim k As Integer Dim zrs As Integer Dim hs As Integer Dim hj As Integer Dim tem As Single Sheet1.Activate zrs = Range("a65536").End(xlUp).Row For i = 2 To Worksheets.Count Worksheets(i).Activate Sheet1.Cells(1, i).Value = Range("b1").Value hs = Range("a65536").End(xlUp).Row For j = 2 To hs For k = 2 To zrs If Range("a" & j).Value = Sheet1.Range("A" & k).Value Then Sheet1.Cells(k, i) = Range("B" & j).Value End If Next k Next j Next i Sheet1.Select i = Worksheets.Count + 1 Cells(1, i) = "合计" For j = 2 To zrs tem = 0 For k = 2 To Worksheets.Count tem = tem + Cells(j, k) Next k Cells(j, i) = tem Next j End Sub 甲流感统计表 '该程序统计每天的H1N1的防控情况 '程序由枣阳市职教中心学校罗艳军开发 Sub saix() Dim lh As Integer lh = ActiveCell.Column Dim i As Long Dim j As Integer 'On Error Resume Next Sheets("当天表").Delete Worksheets.Add ActiveSheet.Name = "当天表" Worksheets("当天表").Select ActiveSheet.Cells(1, 1) = Worksheets("200909").Cells(1, 1) ActiveSheet.Cells(1, 2) = Worksheets("200909").Cells(1, 2) ActiveSheet.Cells(1, 3) = Worksheets("200909").Cells(1, 3) ActiveSheet.Cells(1, 4) = Worksheets("200909").Cells(1, 4) ActiveSheet.Cells(1, 5) = Worksheets("200909").Cells(1, 5) ActiveSheet.Cells(1, 6) = Worksheets("200909").Cells(1, lh) Worksheets("200909").Activate j = 2 For i = 2 To 1970 If ActiveSheet.Cells(i, lh).Value <> "-" Then Worksheets("当天表").Cells(j, 1) = ActiveSheet.Cells(i, 1) Worksheets("当天表").Cells(j, 2) = ActiveSheet.Cells(i, 2) Worksheets("当天表").Cells(j, 3) = ActiveSheet.Cells(i, 3) Worksheets("当天表").Cells(j, 4) = ActiveSheet.Cells(i, 4) Worksheets("当天表").Cells(j, 5) = ActiveSheet.Cells(i, 5) Worksheets("当天表").Cells(j, 6) = ActiveSheet.Cells(i, lh) j = j + 1 End If Next i '以下是美化工作表，给表添加上表头，是录制的宏 Worksheets("当天表").Select Rows("1:1").Select Selection.Insert Shift:=xlDown Selection.RowHeight = 27 Range("A1:F1").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.Merge Range("A1:F1").Select ActiveCell.FormulaR1C1 = "枣阳市职教中心学校晨检午检晚检每日汇总表" Range("A1:F1").Select With Selection.Font .Name = "宋体" .Size = 14 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Selection.Font.Bold = True With Selection.Font .Name = "黑体" .Size = 14 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With '添加统计 ActiveSheet.Cells(j + 1, 1) = "合计" ActiveSheet.Cells(j + 1, 2) = "感冒" ActiveSheet.Cells(j + 2, 2) = "发烧" ActiveSheet.Cells(j + 3, 2) = "咳嗽" 'ActiveSheet.Cells(j + 1, 3).Formula = "=COUNTIF(C[3],""感冒"")" & "人" 'ActiveSheet.Cells(j + 1, 3).Formula = application.WorksheetFunction.CountIf(C[3],"感冒") ActiveSheet.Cells(j + 1, 3).Activate ActiveCell.FormulaR1C1 = "=COUNTIF(C[3],""感冒"")" ActiveSheet.Cells(j + 2, 3).Activate ActiveCell.FormulaR1C1 = "=COUNTIF(C[3],""发烧"")" ActiveSheet.Cells(j + 3, 3).Activate ActiveCell.FormulaR1C1 = "=COUNTIF(C[3],""咳嗽"")" End Sub 七中信息库 Sub a() UserForm1.Show End Sub Private Sub CommandButton1_Click() Dim mrow As Long mrow = Range("a65536").End(xlUp).Row + 1 Range("A" & mrow) = TextBox1.Value Range("B" & mrow) = TextBox2.Value Range("C" & mrow) = ComboBox1.Value Range("D" & mrow) = TextBox3.Value Range("E" & mrow) = ComboBox2.Value Range("F" & mrow) = ComboBox3.Value Range("G" & mrow) = TextBox4.Value Range("H" & mrow) = TextBox5.Value TextBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" TextBox4.Value = "" TextBox5.Value = "" ComboBox1.Value = "" ComboBox2.Value = "" ComboBox3.Value = "" TextBox1.SetFocus End Sub Private Sub CommandButton2_Click() Unload Me End Sub Private Sub UserForm_Initialize() ComboBox1.AddItem "男" ComboBox1.AddItem "女" ComboBox2.AddItem "博士" ComboBox2.AddItem "硕士" ComboBox2.AddItem "大学" ComboBox2.AddItem "大专" ComboBox2.AddItem "高中" ComboBox2.AddItem "初中" ComboBox2.AddItem " 小学 小学生如何制作手抄报课件柳垭小学关于三违自查自纠报告小学英语获奖优质说课课件小学足球课教案全集小学语文新课程标准测试题 " ComboBox3.AddItem "中高" ComboBox3.AddItem "中一" ComboBox3.AddItem "中二" ComboBox3.AddItem "中三" ComboBox3.AddItem "小高" End Sub 随机生成汉字 方法 快递客服问题件处理详细方法山木方法pdf计算方法pdf华与华方法下载八字理论方法下载 一：工作表中用函数 说明 关于失联党员情况说明岗位说明总经理岗位说明书会计岗位说明书行政主管岗位说明书 ：区位码是与汉字一一对应的编码，用四位数字表示，前两位从01到94称区码，后两位从01到94称位码。 一个汉字的前一半是 ASCⅡ码为“160＋区码”的字符，后一半是ASCⅡ码为“160＋ 位码”的字符。每区256字。 例如：B17单元格中输入“=CHAR(($A17+160)*256+B$1+160)” 随机生成汉字方法二：用VBA法 Sub 随机生成汉字() '罗艳军 于2009年10月2日 Dim i, j As Integer For i = 1 To 10 For j = 1 To 10 Cells(i, j) = Chr((Int(Rnd * 79) + 15 + 160) * 256 + Int(Rnd * 94) + 160) Next j Next i End Sub