Developing.ru

Код: Выделить всё

Sub Create_report()
   ExportCSV "D:\Work\Отчет о состоянии требований.csv"
End Sub
 
Public Sub ExportCSV(sFile As String)
 
    Dim f As Integer
 
    Dim s As String
    Dim sCell As String
 
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim iFirstRow As Long
    Dim iLastRow As Long
 
    Dim ECL As Variant
    ECL = Array(1, 3, 4, 8, 9) 'Индексы экспортируемых колонок
    Const cQ As String = """"
 
    On Error Resume Next
    Kill sFile  'уничтожаем старый файл отчёта на тот случай если количество строк сократилось
    f = FreeFile
    Open sFile For Binary As #f
    If Err.Number <> 0 Then
       MsgBox "Ошибка создания файла отчёта", vbCritical, ""
       Exit Sub
    End If
    'Предполагаем что первая колонка экспорта заполненна полностью
    With ActiveSheet
        k = CLng(ECL(0))
        If Len(.Cells(1, k).Value) = 0 Then
            iFirstRow = .Cells(1, k).End(xlDown).Row
        Else
            iFirstRow = 1
        End If
        iLastRow = .Cells(.Rows.Count, ECL(0)).End(xlUp).Row 'последняя строка нашего листа
        For i = iFirstRow To iLastRow
            s = vbNullString
            For k = LBound(ECL) To UBound(ECL)
                j = ECL(k)
                sCell = Trim$(.Cells(i, j).Value)
                If Len(sCell) > 0 Then
                    sCell = Replace(sCell, cQ, cQ & cQ) 'удваиваем присутствующие кавычки
                    'если нужно перекодировать текст вставляем код для перекодировки сюда
                End If
                'если нужно добавляем сюда условие для квотирования дат
                If InStr(sCell, cQ) + InStr(sCell, " ") + InStr(sCell, ";") > 0 Then
                    sCell = cQ & sCell & cQ
                End If
                s = s & sCell
                If k < UBound(ECL) Then
                    s = s & ";"
                End If
            Next k
            s = s & vbCrLf
            Put #f, , s
        Next i
    End With
    Close #f
End Sub