Public Sub QqYunContactTransferCsvFile()
'应用程序设置
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual '错误处理
'On Error GoTo ErrHandler '计时器
Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer '变量声明
Dim Wb As Workbook
Dim Sht As Worksheet
Dim Rng As Range
Dim Arr As Variant
Dim EndRow As Long
Const SplitCount As Long = 100
Dim RecordIndex As Long
Dim FileCount As Long
Dim EachLine As String
Dim WholeLine As String
Dim i As Long, j As Long
Dim HeadLine As String '实例化对象
Set Wb = Application.ThisWorkbook Set Sht = Wb.Worksheets("通讯录") With Sht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A1:Y" & EndRow)
Arr = Rng.Value
RecordIndex = 0
FileCount = 0
HeadLine = ""
For j = LBound(Arr, 2) To UBound(Arr, 2)
HeadLine = HeadLine & """" & Arr(1, j) & ""","
Next j
WholeLine = HeadLine For i = LBound(Arr) + 1 To UBound(Arr)
RecordIndex = RecordIndex + 1
EachLine = ""
For j = LBound(Arr, 2) To UBound(Arr, 2)
EachLine = EachLine & """" & Arr(i, j) & """," '有双引号
'EachLine = EachLine & Arr(i, j) & ","'无双引号
Next j
WholeLine = WholeLine & EachLine & vbCrLf If RecordIndex Mod SplitCount = (SplitCount - 1) Or i = UBound(Arr) Then '生成文件的条件
FileCount = FileCount + 1
Open Wb.Path & "\" & FileCount & ".csv" For Output As #1 '生成CSV文件
Print #1, WholeLine '写入CSV的内容
Close #1 '关闭文件句柄
WholeLine = HeadLine
End If Next i
End With '运行耗时
UsedTime = VBA.Timer - StartTime ErrorExit: '错误处理结束，开始环境清理
Set Wb = Nothing
Set Sht = Nothing
Set Rng = Nothing Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "！", vbCritical, "错误提示！"
'Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub