'撰写:老朽
'网址:http://Club.ExcelHome.net
'日期:2009-7-18 下午 04:41:30
Option Explicit
'撰写:老朽
'网址:http://Club.ExcelHome.net
'日期:2009-7-18 下午 04:41:30
Sub zldccmx()
Application.ScreenUpdating = False '禁止屏幕更新
Application.EnableEvents = False '禁止响应系统事件
Application.Visible = False '让EXCEL 暂时不可见
Application.DisplayAlerts = False '关闭系统警告
On Error GoTo Ex '一旦出错就结束
Dim Arr, I, J, K, L, M, Nwk As Workbook
Arr = Sheets("客户信息").UsedRange
For I = 3 To UBound (Arr)
If Arr(I, 3) = "" Then Exit For '如果C列名字为空就结束循环
Sheets(Array("附件1", "附件2")).Copy '将附件1、附件2导出为一个新的工作表
Set Nwk = ActiveWorkbook '指向一个对象
With Nwk.Sheets("附件1") '以下是对附件1表进行填写数据
.[b3] = Arr(I, 3)
.[l3] = Arr(I, 6)
.[u3] = Arr(I, 7)
.[X3] = Arr(I, 8)
.[B4] = Arr(I, 9)
.[X4] = Arr(I, 10)
ReDim Brr$(1 To 5, 1 To 25)
Brr(1, 1) = Arr(I, 3): Brr(1, 2) = "户主"
For K = 1 To 18
Brr(1, K + 2) = Mid(Arr(I, 2), K, 1)
Next
Brr(1, 21) = Arr(I, 4): Brr(1, 23) = Arr(I, 5): Brr(1, 24) = IIf(IIf(Len(Arr(I, 2)) = 18, Mid(Arr(I, 2), 17, 1), Mid(Arr(I, 2), 15, 1)) Mod 2 = 1, "男", "女"): Brr(1, 25) = Arr(I, 8)
For J = 2 To 5
M = 11 + (J - 2) * 6
If Arr(I, M) <> "" Then
Brr(J, 1) = Arr(I, M): Brr(J, 2) = Arr(I, M + 1): For K = 1 To 18: Brr(J, K + 2) = Mid(Arr(I, M + 2), K, 1): Next
Brr(J, 21) = Arr(I, M + 3): Brr(J, 23) = Arr(I, M + 4): Brr(J, 24) = IIf(IIf(Len(Arr(I, 2)) = 18, Mid(Arr(I, M + 2), 17, 1), Mid(Arr(I, 2), 15, 1)) Mod 2 = 1, "男", "女"): Brr(J, 25) = Arr(I, M + 5)
End If
Next
.[A7].Resize(5, 25) = Brr
.[A15] = Arr(I, 35): .[B15] = Arr(I, 36): .[H15] = Arr(I, 37): .[P15] = Arr(I, 38)
.[A16] = Arr(I, 39): .[B16] = Arr(I, 40): .[H16] = Arr(I, 41): .[P16] = Arr(I, 42)
.[U15] = Arr(I, 43): .[V15] = Arr(I, 44): .[X15] = Arr(I, 45)
.[U16] = Arr(I, 46): .[V16] = Arr(I, 47): .[X16] = Arr(I, 48)
.[U17] = .[P15] + .[P16] + .[X15] + .[X16]
.[A20] = Arr(I, 49): .[C20] = Arr(I, 50): .[M20] = Arr(I, 51): .[X20] = Arr(I, 52)
.[A22] = Arr(I, 53): .[C22] = Arr(I, 54): .[M22] = Arr(I, 55): .[X22] = Arr(I, 56)
.[C24] = "收入来源：" & Arr(I, 57): .[X24] = Arr(I, 58)
.[R25] = .[X24] + .[X23] + .[X22] + .[X20]
.[R26] = .[U17] + .[R25]
ReDim Brr(1 To 2, 1 To 25)
Brr(1, 1) = Arr(I, 59): Brr(1, 3) = Arr(I, 60)
Brr(1, 9) = Arr(I, 61): Brr(1, 15) = Arr(I, 62)
Brr(1, 21) = Arr(I, 63): Brr(1, 23) = Arr(I, 64): Brr(1, 25) = Arr(I, 65)
Brr(2, 1) = Arr(I, 66): Brr(2, 3) = Arr(I, 67)
Brr(2, 9) = Arr(I, 68): Brr(2, 15) = Arr(I, 69)
Brr(2, 21) = Arr(I, 70): Brr(2, 23) = Arr(I, 71): Brr(2, 25) = Arr(I, 72)
.[A31].Resize(2, 25) = Brr
ReDim Brr(1 To 2, 1 To 25)
Brr(1, 1) = Arr(I, 73): Brr(1, 9) = Arr(I, 74)
Brr(1, 21) = Arr(I, 75): Brr(1, 23) = Arr(I, 76): Brr(1, 25) = Arr(I, 77)
Brr(2, 1) = Arr(I, 78): Brr(2, 9) = Arr(I, 79)
Brr(2, 21) = Arr(I, 80): Brr(2, 23) = Arr(I, 81): Brr(2, 25) = Arr(I, 82)
.[A35].Resize(2, 25) = Brr
End With
With Nwk.Sheets("附件2") '以下是对附件2表进行填写数据
.[A4] = Arr(I, 83): .[B4] = Arr(I, 84): .[F4] = Arr(I, 85): .[I4] = Arr(I, 86)
.[F8] = Arr(I, 87): .[F9] = Arr(I, 88): .[F11] = Arr(I, 89): .[F12] = Arr(I, 90)
For M = 1 To 5
If Arr(I, 90 + M) <> "" Then
.Range("B" & 18 + M).Resize(1, 9).Find(Arr(I, 90 + M), , , xlWhole).Offset(0, 1) = "√"
End If
Next
If Arr(I, 96) <> "" Then .[D22] = "√": .[D23] = Arr(I, 96)
For M = 7 To 8
If Arr(I, 90 + M) <> "" Then
.Range("B" & 17 + M).Resize(1, 9).Find(Arr(I, 90 + M), , , xlWhole).Offset(0, 1).Value = "√"
End If
Next
.[B26] = Arr(I, 99)
.[A29] = Arr(I, 100): .[F29] = Arr(I, 101): .[I29] = Arr(I, 102)
.[A30] = Arr(I, 103): .[F30] = Arr(I, 104): .[I30] = Arr(I, 105)
.[A31] = Arr(I, 106)
.[I34] = Arr(I, 3) '自动添加签名
End With
Nwk.SaveAs "D:\" & Arr(I, 3) & ".XLS" '将新生成的工作簿用户主姓名存盘
Nwk.Close '关闭刚刚生成的工作簿
Next
Ex: If Err.Number <> 0 Then MsgBox Err.Description '如果出现错误，就弹出错误对话框，显示错误描述
Application.ScreenUpdating = True '恢复屏幕实时更新
Application.EnableEvents = True '恢复系统事件响应
Application.Visible = True '恢复EXCEL应用可见
End Sub
|
楼主: 与心
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-7-18 16:41
楼主
