|
|
这个表是用VBA生成的（通过在一个模板中录入数据，然后复制生成此文件）
我把代码贴出来吧，帮我看看问题在哪
谢谢。- Sub 新建拷贝法()
- 'On Error Resume Next
- On Error GoTo Err
- '关闭显示刷新，避免闪烁
- Application.ScreenUpdating = False
- Application.EnableEvents = False
-
- '选清除高亮显示
- Cells.FormatConditions.Delete
-
- '验证必填项是否完整
- 'If [H2] = "" Or [l2] = "" Or [i4] = "" Then
- Select Case ""
- Case [H2]
- Range("H2").Activate
- MsgBox "“单据类型编号 H2” 为必填！", vbQuestion, "数据不完整"
- Application.ScreenUpdating = True
- Application.EnableEvents = True
- Exit Sub
- Case [L2]
- Range("L2").Activate
- MsgBox " “单据序号 L2” 为必填！ " & Chr(13) & "如果你确定“I2“的值并非公式生成，可以在L2中填上任意值跳过此步。", VbMsgBoxStyle.vbOKOnly + vbQuestion, "数据不完整"
- Application.ScreenUpdating = True
- Application.EnableEvents = True
- Exit Sub
- Case [I4]
- Range("I4").Activate
- MsgBox "“发货仓库 I4” 为必填！", vbQuestion, "数据不完整"
- Application.ScreenUpdating = True
- Application.EnableEvents = True
- Exit Sub
- ' Case Else
- ' f_name = f_name + "XXXXXXXX.xls"
- End Select
-
-
-
- Dim zj_name As String
-
- 设置文件名
-
- zj_name = "发货清单_模版.xls" 'Application.ActiveWorkbook.Name
- If zj_name <> Application.ActiveWorkbook.Name Then
- MsgBox "“发货清单_模版”打开中，Ctrl+s被占用。请用菜单中的保存功能！"
- Exit Sub
- Else
- 'MsgBox "Yes"
- End If
- ' MsgBox zj_name, , ""
- ' MsgBox f_dir, , ""
- ' MsgBox f_name, , ""
- '--------------------0判断文件是否已经打开-----------------------------
-
- If WbkExt((f_name)) Then '系统说这家伙怕冷要两括号包着才能工作
- 'MsgBox f_name
- Dim Response As Integer
- Response = MsgBox(f_name & Chr(13) & "是不让它滚开，并生成单据？", 4 + 16, " 已经打开")
- If Response = vbYes Then
-
- Workbooks(f_name).Close SaveChanges:=False
-
- Else
- Exit Sub
- End If
- Else
- 'MsgBox f_name & " 未打开"
- End If
-
- '--------------------1判断文件是否已经打开-----------------------------
- '--------------------0判断文件是否已经存在-----------------------------
- Set fs = CreateObject("Scripting.FileSystemObject")
- If fs.FileExists(f_dir + f_name) = True Then '存在
- Dim scf As String
- scf = MsgBox("此文件已经存在，是否覆盖？", 4 + 32 + 256, "")
- If (scf = vbNo) Then
- MsgBox "取消了文件导出,原来那份还活着,快去求她吧!", , ""
- Exit Sub
- End If
- ' Else
- End If
- '--------------------1判断文件是否已经存在-----------------------------
- '--------------------0复制工作表并清除公式-----------------------------
- Sheets("存根联").Select
- Sheets("存根联").Copy
-
- ' '--------------------1复制工作表并清除公式-----------------------------
-
- '=======================================================================
- Application.DisplayAlerts = False
- Application.EnableEvents = False
- ' '--------------------0清除公式-----------------------------
- '------------------保存 并且不提示--------------------------
- ActiveWorkbook.SaveAs Filename:= _
- f_dir + f_name, FileFormat:=xlNormal, _
- Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
- CreateBackup:=False
- '--------清除工程代码
-
- 清除工程代码 (f_dir + f_name)
-
-
- '------------------保存 并且不提示--------------------------
- Workbooks.Open (f_dir + f_name)
- ' ActiveWindow.Visible = False
- 'Windows(f_dir + f_name).Visible = False
-
- Application.Workbooks(f_name).Sheets("存根联").Select
- Cells.Select
- Selection.Copy
- Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
- :=False, Transpose:=False
- Application.CutCopyMode = False
- ' '--------------------1清除公式-----------------------------
- '------------------消除右边的辅助内容--------------------------
- Columns("IV").Select
- Selection.Delete Shift:=xlToLeft
- Columns("K:S").Select
- Selection.Delete Shift:=xlToLeft
- '------------------消除右边的辅助内容--------------------------
- '修改完后保存
- Workbooks(f_name).Saved = True
- Workbooks(f_name).Close SaveChanges:=True
-
- Application.EnableEvents = True
- Application.DisplayAlerts = True
- '=======================================================================
-
- '回到"存根联"
- Windows(zj_name).Activate
- Sheets("存根联").Select
-
- MsgBox f_name & Chr(13) & Chr(13) & "保存成功。", vbInformation, "生成提示"
-
- '打开显示刷新
- Application.ScreenUpdating = True
- Application.EnableEvents = True
- Err:
- Application.EnableEvents = True
-
- End Sub
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2008-12-16 12:41
楼主
我的也这样
