VBA代码收集整理

开始-打印机和传真机-右健该打印机图标-打印首选项-灰度打印或黑色打印前面加勾就可以了.

Private Sub 添加_Click()

If 员工编号.Value = \"\" Or 姓名 = \"\" Then Exit Sub

Dim A As Range

Set A = Sheets(\"员工信息\").Cells.Find(员工编号)

If Not A Is Nothing Then

MsgBox \"已存在该编号记录\"

Exit Sub

End If

'***********************************

On Error Resume Next

Dim x As Integer, Y As Integer

Dim Mrng As Range

With Sheets(\"员工信息\")

Y = .Range(\"A65536\").End(xlUp).Row + 1

For x = 1 To Me.Controls.Count

Set Mrng = .Cells.Find(Me.Controls(x).Name)

.Cells(Y, Mrng.Column) = Me.Controls(x).Text

Next x

End With

MsgBox \"添加成功\

Set Mrng = Nothing

清空所有内容

End Sub

Private Sub 修改_Click()

On Error Resume Next

Dim x As Integer, Y As Integer

Dim Mrng As Range

If 姓名 = \"\" Then Exit Sub

With Sheets(\"员工信息\")

Y = .Cells.Find(员工编号).Row

For x = 1 To Me.Controls.Count

Set Mrng = .Cells.Find(Me.Controls(x).Name)

.Cells(Y, Mrng.Column) = Me.Controls(x).Text

Next x

End With

MsgBox \"修改成功\

Set Mrng = Nothing

End Sub

Private Sub 退出_Click()

Unload Me

End Sub

‘自动找到活动工作簿的路径并生成模板

Function FileOpened(BName) As Boolean

On Error Resume Next

If Len(Workbooks(BName).Name) > 0 Then

If Err.Number = 9 Then

FileOpened = False

Else

FileOpened = True

End If

End If

End Function

Function FileExist(FName) As Boolean

Dim x As String

x = Dir(FName)

If x <> \"\" Then

FileExist = True

Else

FileExist = False

End If

End Function

Sub 自动生成模板()

Dim OpenFName$, FileSource$

OpenFName = \"模板.xls\"

FileSource = ActiveWorkbook.Path

If FileOpened(OpenFName) Then

MsgBox OpenFName & \" is opened!\"

Else

If FileExist(FileSource & OpenFName) Then

Workbooks.Open FileSource & OpenFName

Else

ActiveWorkbook.SaveAs ActiveWorkbook.Path & \"\\\" & \"模板.xls\"

End If

End If

End Sub

‘在当前E4单元格自动生成本月第一天的日期和日期格式“yyyy””-“”mm””-“”dd”

Sub 自动生成本月日期()

Range(\"E4\").Select

Selection.NumberFormatLocal = \"d\"

[E4] = Now() - Day(Now()) + 1

End Sub

Sub 插入多个工作表并命名()

On Error GoTo 100

Dim i As Integer

For i = 12 To 1 Step -1

Sheets.Add.Name = i & \"月\"

Next i

100:

Exit Sub

End Sub

Sub 复制到所有工作表()

On Error Resume Next

Dim wth As Integer

Sheets(\"模板\").Rows.Select

For wth = Sheets.Count To 1 Step -1

'复制源文件中第一个工作表的内容

Sheets(\"模板\").Rows.Copy

Sheets(wth).Range(\"A1\").Select

ThisWorkbook.Sheets(wth).Paste

Next wth

End Sub

窗体代码集：

1. CommandButton1控件单击事件，寻找活动工作表中与窗体控件的名称相同的单元格确定其行数，

把窗体控件的值累加上所要找的单元格的值，并相加的和返给指定的单元格。

Private Sub CommandButton1_Click()

On Error Resume Next

Dim x As Integer, Y As Integer

Dim mrng As Range

With ActiveSheet

For x = 1 To Me.Controls.Count

Set mrng = .Cells.Find(Me.Controls(x).Name)

.Cells(mrng.Row, \"AV\") = Me.Controls(x).Value + .Cells(mrng.Row, \"AV\").Value

Next x

End With

MsgBox \"输入成功！\

End Sub

2. CommandButton1控件单击事件，卸载窗体

Private Sub CommandButton2_Click()

Unload Me

End Sub

Sub 运行窗体()

me.Show

End Sub

商印生产施工单自动化改进代码：

清空单元格的颜色（1.2）

Sub 清空更新()

ActiveSheet.UsedRange.Interior.ColorIndex = 0

End Sub

Sub 清空更新()

Rows(\"1:35\").Interior.ColorIndex = 0

End Sub

‘工作表单元格改变事件；单元格编辑改变后变色。

Private Sub Worksheet_Change(ByVal Target As Range)

Target.Interior.ColorIndex = 15

End Sub

Sub 生产编号前端()

Range(\"D3\").Select

Selection.NumberFormatLocal = \"yyyy\"\"\"\"mm\"\"\"\"dd\"

[D3] = Now()

End Sub

Function FileOpened(BName) As Boolean

On Error Resume Next

If Len(Workbooks(BName).Name) > 0 Then

If Err.Number = 9 Then

FileOpened = False

Else

FileOpened = True

End If

End If

End Function

Function FileExist(FName) As Boolean

Dim x As String

x = Dir(FName)

If x <> \"\" Then

FileExist = True

Else

FileExist = False

End If

End Function

Sub 自动生成模板()

Dim OpenFName$, FileSource$

OpenFName = \"模板.xls\"

FileSource = ActiveWorkbook.Path

If FileOpened(OpenFName) Then

MsgBox OpenFName & \" is opened!\"

Else

If FileExist(FileSource & OpenFName) Then

Workbooks.Open FileSource & OpenFName

Else

ActiveWorkbook.SaveAs ActiveWorkbook.Path & \"\\\" & \"模板.xls\"

End If

End If

End Sub