|
|
下面的程序是通过本论坛得到的，我运行时在我个人的机子是提示制作成功，然而我到单位的机子运行却提示“遇到未知错误，请与作者联系”，但工资条实际上还是生成，这是什么原因呢？各位大虾帮帮忙解决一下阿。传个实例，选中有内容的区域，宏－－－pay-slip---运行即可。谢谢大家了
'Option Explicit
Dim PayC As Integer '用户选定区域的列数
Dim PayR As Integer '用户选定区域的行数
Sub Pay_Slip()
Dim PayCF As Integer '用户选定区域的第一列列号
Dim PayTitleC1 As Integer '将工作表工资项目赋值到数组时的列号
Dim PayTitleC2 As Integer '将工作表工资条内容赋值到数组时的列号
Dim PayRF As Integer '用户选定区域的第一行行号
Dim PayTitle(100) '工资条项目
Dim PaySum(100) '工资条内容
Dim PaySumR1 As Integer '将工作表工资条内容赋值到数组时的行号
Dim N1 As Integer '计数器
Dim C1 As Integer '判断用计数器
Dim N2 As Integer '数组上标计数器
Dim N3 As Integer '逐行读写工作表内容计数器
Dim TargetR As Integer '工资条工资项目行号
Dim TargetC As Integer '工资条工资项目列标
Dim WName As String '当前工作簿所有工作表名称
Dim abc
Dim cba
Dim Oldsheet '原激活工作表名称
Oldsheet = ActiveSheet.Name
PayC = Selection.Columns.Count
PayR = Selection.Rows.Count
PayCF = Selection.Column
PayRF = Selection.Row
PayTitleC1 = PayCF
PayTitleC2 = PayCF
C1 = 1
N2 = 0
TargetR = 10000
TargetC = 1
PaySumR1 = PayRF + 1
For Each Worksheet In Worksheets '检查有无同名工作表
abc = Worksheet.Name
If abc = "Excel Home--工资条" Then
cba = 0
Sheets("Excel Home--工资条").Select
Cells.Select
Selection.Delete Shift:=xlUp
Exit For
Else
cba = 1
End If
Next
If cba = 1 Then
abc = MsgBox("下面的工作将要在您的工作簿中新建一张名为“Excel Home--工资条”的工作表，请先确认您的工作簿中尚无这样命名的工作表。要继续吗？", _
vbYesNo + vbQuestion, Title:="工资条")
If abc = 7 Then
Cancel = True
MsgBox "您取消了本次操作!", vbQuestion, "工资条"
Exit Sub
End If
Worksheets.Add '生成新工作表
On Error GoTo WRONG
With ActiveSheet
.Name = "Excel Home--工资条"
End With
End If
Sheets(Oldsheet).Select
For N1 = 1 To PayC '将工作表工资项目赋值到数组
PayTitle(N1 - 1) = Cells(PayRF, PayTitleC1)
PayTitleC1 = PayTitleC1 + 1
Next
Application.ScreenUpdating = False '关闭屏幕更新
Application.StatusBar = "正在读取工资数据文件..."
For N3 = 1 To PayR - 1
For N1 = 1 To PayC '将工作表工资数值赋值到数组
PaySum(N1 - 1) = Cells(PaySumR1, PayTitleC2)
PayTitleC2 = PayTitleC2 + 1
Next
Application.StatusBar = "正在生成工资条..."
For N1 = 1 To PayC
On Error GoTo WRONG
Cells(TargetR, TargetC).Value = PayTitle(N2) '写入工资条项目
On Error GoTo WRONG
Cells(TargetR + 1, TargetC).Value = PaySum(N2) '写入工资条内容
Range(Cells(TargetR, 1), Cells(TargetR + 1, 8)).Select '画网格线
Border1
N2 = N2 + 1
C1 = C1 + 1
TargetC = TargetC + 1
If C1 = 9 Then
TargetR = TargetR + 2
TargetC = 1
C1 = 1
End If
Next
PaySumR1 = PaySumR1 + 1
If PayC / 8 = Int(PayC / 8) Then
TargetR = TargetR + 2
Else
TargetR = TargetR + 4
End If
PayTitleC2 = PayCF
TargetC = 1
C1 = 1
N2 = 0
'画虚线
Range(Cells(TargetR - 2, 1), Cells(TargetR - 2, 8)).Select
Border2
Next
'将工资条复制到新工作表中
Range(Cells(10000, 1), Cells(TargetR, 8)).Select
Selection.Copy
On Error GoTo WRONG
Sheets("Excel Home--工资条").Select
Range("A2").Select
On Error GoTo WRONG
ActiveSheet.Paste
Application.CutCopyMode = False
Setting '设置居中,列宽,字体等格式
Sheets(Oldsheet).Select '将过程数据删除
Selection.Delete Shift:=xlToLeft
Sheets("Excel Home--工资条").Select
PageSetting '页面设置
PageBreak '设置分页符
Application.ScreenUpdating = True '恢复屏幕更新
Application.StatusBar = False
MsgBox "恭喜！恭喜！工资条完成！" & vbCrLf & _
"这是陈奋搞的工资条打印工具。" & vbCrLf & "该程序现只能用A4纸打印纵向的工资条 " _
& vbCrLf & "生成之前一定要将工资表涂黑选定工资条才会正确输出！" _
& vbCrLf & "如果您还有其他疑问或问题，请与本人联系： " & vbCrLf & _
" 陈奋 13510431088", vbInformation + vbOKOnly, "工资条"
Exit Sub
WRONG:
MsgBox "遇到未知错误，无法生成工资条！请与作者联系！", vbExclamation, "工资条"
Exit Sub
End Sub
Sub Border1()
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
Sub Border2()
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDash
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
End Sub
Sub Setting()
With Selection '设置居中,列宽,字体等格式
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
.ColumnWidth = 11
End With
With Selection.Font
.Name = "宋体"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End Sub
Sub PageSetting() '打印页面设置
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.196850393700787)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.31496062992126)
.BottomMargin = Application.InchesToPoints(0.31496062992126)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 360
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With
End Sub
Sub PageBreak() '设置分页符
Dim BreakR As Integer '设置分页符的位置
Dim BR As Integer '设置分页符的位置（行号）
Dim N1 As Integer '计数器
Select Case PayC
Case 1 To 8
BreakR = 52
Case 9 To 16
BreakR = 54
Case 17 To 24
BreakR = 48
Case 25 To 32
break = 50
Case 33 To 40
BreakR = 48
Case 41 To 48
BreakR = 42
Case 49 To 56
BreakR = 48
Case 57 To 64
BreakR = 54
Case 65 To 72
BreakR = 40
Case 73 To 80
BreakR = 44
End Select
BR = BreakR
With Worksheets("Excel Home--工资条")
For N1 = 1 To PayR
.HPageBreaks.Add .Range(Cells(BR + 1, 1), Cells(BR + 1, 8))
BR = BreakR + BR
Next N1
End With
End Sub
AceSVldQ.rar
(19.7 KB, 下载次数: 9)
[此贴子已经被作者于2005-4-13 21:06:46编辑过] |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-4-13 19:59