希望在excel中创建宏, 或者一段语句能实现一些功能。

2024-10-31 19:24:06
有3个网友回答
网友(1):

这个我以前刚好做过,比较麻烦,请按以下步骤执行:
1. 插入一个新的Sheet,命名为INSTRUCTIONS
里面写一些信息:如想使用本文档,必须允许宏的运行。每次保存后会回到本页,请按View Doc继续审阅。 View Doc是一个按钮。
2. 把包含必填项数据的Sheet命名为Doc
3. 把Doc表里所以必填项选中,并命名为Mandatory_field
4. 按ALT+F11进入宏编辑
5. 插入新模块
6. 复制粘贴以下代码至模块1
Public Function Save_Validation() As Boolean
Dim r As Excel.Range

For Each r In ActiveSheet.UsedRange
If NAMEDRANGE(r.Address) = "Mandatory_field" Then
If r.Value = "" Then
r.Select
MsgBox "Missing value in a mandatory field: '" & r.Address & "'" & Chr(13) & "You must ffulfill all mandatory fields before saving"
Save_Validation = False
Exit Function
End If
End If
Next r
Save_Validation = True
End Function
Public Function NAMEDRANGE(celRef As Variant) As String

'Declare variables
Dim iName As Name, wbCall As Workbook, blnApprox As Boolean
Dim NRange As String
On Error Resume Next
'Check if celRef is a Range
If TypeOf celRef Is Range Then
celRef = celRef.Address
End If
If Not celRef Like "*!$" Then
celRef = Application.Caller.Parent.Name & "!" & celRef
If Err = 424 Then celRef = Range(celRef).Parent.Name & "!" & celRef
Err.Clear
End If

'Set function caller (dynamic)
Set wbCall = Workbooks(Application.Caller.Parent.Parent.Name)

'If called from VBA, then ..
If Err = 424 Then Set wbCall = ActiveWorkbook
On Error GoTo Err_Exit

'Loop through all names in workbook
For Each iName In wbCall.Names

'If name matches specified parameter
If iName.RefersTo = "=" & celRef Then
'Exact match
NAMEDRANGE = iName.Name
Set wbCall = Nothing
Exit Function
ElseIf Not Intersect(Range(celRef), Range(iName.RefersTo)) Is Nothing Then

'Checks for range being anywhere in any intersect in any named range

NRange = NRange & "'" & iName.Name & "', "
'NAMEDRANGE = "Intersects " & Left(NRange, Len(NRange) - 2)
NAMEDRANGE = iName.Name
blnApprox = True
End If

Next

Err_Exit:

'If not found, mark it and release variable.
If Not blnApprox Then NAMEDRANGE = "Not Found"
Set wbCall = Nothing

End Function
Sub Button1_Click()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
Select Case UCase(ws.Name)
Case Is <> "INSTRUCTIONS"
ws.Visible = True
End Select
Next ws
Sheets("INSTRUCTIONS").Visible = xlVeryHidden
Application.ScreenUpdating = True
End Sub

7. 将步骤1中提到的View Doc按钮赋予宏Button1_Click()
8. 在宏编辑器中双击ThisWorkbook,并粘贴以下代码:
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, cancel As Boolean)
Dim ws As Worksheet

If Save_Validation() = False Then
cancel = True
Exit Sub
End If

Sheets("INSTRUCTIONS").Visible = True
For Each ws In ActiveWorkbook.Worksheets
Select Case UCase(ws.Name)
Case Is <> "INSTRUCTIONS"
ws.Visible = xlVeryHidden
End Select
Next ws
Sheets("INSTRUCTIONS").Range("$B$5").Select
Application.ScreenUpdating = True

End Sub
Private Sub Workbook_BeforeClose(cancel As Boolean)
Dim ws As Worksheet
Dim Response As Integer

If Save_Validation() = False Then
Response = MsgBox("You cannot save before fulfill all the mandatory fields" & Chr(13) & Chr(13) & "Press OK: force to close file without saving!!!" & Chr(13) & "Press cancel: return to the field you may need to fill...", vbOKCancel, "Warning!!!")
If Response = 2 Then
cancel = True
Exit Sub
End If
If Response = 1 Then
Application.ScreenUpdating = False
Sheets("INSTRUCTIONS").Visible = True
For Each ws In ActiveWorkbook.Worksheets
Select Case UCase(ws.Name)
Case Is <> "INSTRUCTIONS"
ws.Visible = xlVeryHidden
End Select
Next ws
Application.ScreenUpdating = True
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
End If
End If
Application.ScreenUpdating = False
Sheets("INSTRUCTIONS").Visible = True
For Each ws In ActiveWorkbook.Worksheets
Select Case UCase(ws.Name)
Case Is <> "INSTRUCTIONS"
ws.Visible = xlVeryHidden
End Select
Next ws
Sheets("INSTRUCTIONS").Range("$B$2").Select
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
End Sub
Private Sub Workbook_Open()
Dim ws As Worksheet

Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
Select Case UCase(ws.Name)
Case Is <> "INSTRUCTIONS"
ws.Visible = True
End Select
Next ws
Sheets("data").Visible = False
Sheets("INSTRUCTIONS").Visible = xlVeryHidden
Application.ScreenUpdating = True
End Sub
Private Sub init()
Dim ws As Worksheet

Application.ScreenUpdating = False
Sheets("INSTRUCTIONS").Visible = True
For Each ws In ActiveWorkbook.Worksheets
Select Case UCase(ws.Name)
Case Is <> "INSTRUCTIONS"
ws.Visible = xlVeryHidden
End Select
Next ws
Application.ScreenUpdating = True
End Sub

然后就可以用了。当你有必填项未填时,会自动跳到下一个未填单元格,会有提示,但是我以前做的是英文的。有未填项时不能保存。因为关闭文档会先自动保存,所以会先提示,然后会跳出第二个对话框问是否强制退出,强制退出将不保存文档,不强制退出则继续填写

网友(2):

在输入过程中不进行检查,在保存、退出时执行检查并提示。
thisworkbook代码如下:

Public aa As Boolean

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim I As Integer
Dim flag As Boolean
If aa = True Then
ActiveWorkbook.Close (False)
Exit Sub
End If
flag = False
For I = 1 To 4
If Cells(I, 4) = "" Then
flag = True
Exit For
End If
Next I
If flag = True Then
X = MsgBox("输入不完整,无法保存!" & vbCrLf & "按确定将不保存数据强制退出,按取消返回重新录入数据", vbOKCancel)
If X = 1 Then
aa = True
ActiveWorkbook.Close (False)
Else
Cancel = True
End If
End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim I As Integer
Dim flag As Boolean
flag = False
For I = 1 To 4
If Cells(I, 4) = "" Then
flag = True
Exit For
End If
Next I
If flag = True Then
MsgBox "输入不完整,无法保存!"
Cancel = True
End If

End Sub

网友(3):

打开工具,宏,VISUAL BASIC编辑器,在弹出的窗口里面可以直接输入代码,然后按F5运行了。