20170624xlVBA生成通讯录文件

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