TopPicLogo TopPicText

MS Excel - Вставляем (удаляем) заголовки столбцов в файл рабочей книги

Полезно перед импортом (подключением) данных Excel

Public Sub esCreateFirstROW_in_ExcelWB(wbSoursePath As String)
'es - 28.07.2012
'Процедура вставляет заголовки столбцов в файл Excel (wbSoursePath)
'ВНИМАНИЕ!
'   MS Excel должен быть закрыт !
'--------------------------------------------------------------------
'Аргументы:
'   wbSoursePath  = Исходный файл
'--------------------------------------------------------------------
Dim objExcelApp As Object
Dim objWorkbook As Object
' ... или так: (Если сылка на [MS Excel XX Object LIB]  установлена.)
'Dim objExcelApp As Excel.Application 'Требуется ссылка на MS Excel XX Object LIB
'Dim objWorkbook As Excel.Workbook    'Требуется ссылка на MS Excel XX Object LIB
'--------------------------------------------------------------------
On Error GoTo esCreateFirstROW_in_ExcelWB_Err
    
    Set objExcelApp = CreateObject("Excel.Application")
    Set objWorkbook = objExcelApp.Workbooks.Open(wbSoursePath)
    'Set objWorkheet = objWorkbook.Worksheets(1)

    With objWorkbook.Worksheets(1)

    '01 - Добавляем одну строку вверх листа :
        .Rows(1).Insert                    'Добавляем одну строку над первой
        .Rows(1).RowHeight = 18            'Выставляем высоту новой строки
        .Range("A1").Select                'Переход в начало листа
        
    '02 - Пищем заголовки столбцов в первую строку ....
        .Range("A1").FormulaR1C1 = "tDetCode"
        .Range("B1").FormulaR1C1 = "tDetCurr"
        .Range("C1").FormulaR1C1 = "tDetPr_01"
        .Range("D1").FormulaR1C1 = "tDetPr_02"
        .Range("E1").FormulaR1C1 = "tDetPr_03"
        .Range("F1").FormulaR1C1 = "tDetPr_04"
        .Range("G1").FormulaR1C1 = "tDetName"
    
        .Range("H1").FormulaR1C1 = "tDetDescr"
        .Range("I1").FormulaR1C1 = "tDetOE"
        .Range("J1").FormulaR1C1 = "tCr01"
        .Range("K1").FormulaR1C1 = "tCr02"
        .Range("L1").FormulaR1C1 = "tCr03"
        .Range("M1").FormulaR1C1 = "tCr04"
    
        .Range("N1").FormulaR1C1 = "tQTY_Main"
        .Range("O1").FormulaR1C1 = "tQTY_Svrd"
    'Хватит пока ...
        '.Range("P1").FormulaR1C1 = ""       ' ... и т.д. ...
        '.Range("Q1").FormulaR1C1 = ""
        '.Range("R1").FormulaR1C1 = ""
        '.Range("S1").FormulaR1C1 = ""
        '.Range("T1").FormulaR1C1 = ""
    End With
'--------------------------------------------------------------------
'Сохраняем РЕЗУЛЬТАТ ...
    objWorkbook.Save
    DoEvents
    
esCreateFirstROW_in_ExcelWB_Bye:  'Закрываем всё!
    On Error Resume Next
    'Set objWorkheet = Nothing
    objWorkbook.Close
    Set objWorkbook = Nothing
    objExcelApp.Quit
    Set objExcelApp = Nothing
    Err.Clear
    Exit Sub

esCreateFirstROW_in_ExcelWB_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure esSRS_1C_Rep_MarkFirstROW", vbCritical, "Error!"
    Resume esCreateFirstROW_in_ExcelWB_Bye
End Sub

Теперь процедура ОБРАТНАЯ предидущей (прибераемся за собой)

Public Sub esDeleteFirstROW_in_ExcelWB(wbSoursePath As String)
'es - 28.07.2012
'Процедура удаляет заголовки столбцов в файле Excel (wbSoursePath)
'   применяется после работы процедуры: esCreateFirstROW_in_ExcelWB (See Above)
'--------------------------------------------------------------------
'ВНИМАНИЕ!
'   MS Excel должен быть закрыт !
'--------------------------------------------------------------------
'Аргументы:
'   wbSoursePath  = Исходный файл
'--------------------------------------------------------------------
Dim objExcelApp As Object
Dim objWorkbook As Object
'--------------------------------------------------------------------
On Error GoTo esDeleteFirstROW_in_ExcelWB_Err
    
    Set objExcelApp = CreateObject("Excel.Application")
    Set objWorkbook = objExcelApp.Workbooks.Open(wbSoursePath)

'01 - Проверяем есть ли "удаляемое" в файле - просто сверив значение в ячейке
    If objWorkbook.Worksheets(1).Range("A1").FormulaR1C1 <> "tDetCode" Then
        MsgBox "В файле: " & vbCrLf & wbSoursePath & vbCrLf & "Первоя строка, заданного формата не обнаружена!", vbCritical, "Не тот файл!"
        GoTo esDeleteFirstROW_in_ExcelWB_Bye
    End If

'02 - УДАЛЯЕМ певвую строчку:
    objWorkbook.Worksheets(1).Rows(1).Delete -4162

'03 - Сохраняем РЕЗУЛЬТАТ ...
    objWorkbook.Save
    DoEvents
    
esDeleteFirstROW_in_ExcelWB_Bye:  'Закрываем всё!
    On Error Resume Next
    objWorkbook.Close
    Set objWorkbook = Nothing
    objExcelApp.Quit
    Set objExcelApp = Nothing
    Err.Clear
    Exit Sub

esDeleteFirstROW_in_ExcelWB_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure esSRS_1C_Rep_MarkFirstROW", vbCritical, "Error!"
    Resume esDeleteFirstROW_in_ExcelWB_Bye
End Sub



Может пригодится:

Public Function IsExcelOpen() As Boolean
'es - 10.07.2012
'Если MS Excel запущен - вернёт True (-1)
'--------------------------------------------------------------------
Dim objExcelApp As Object
On Error GoTo IsExcelOpenErr
    Set objExcelApp = GetObject(, "Excel.Application")
    IsExcelOpen = True

IsExcelOpenBye:
    On Error Resume Next
    Set objExcelApp = Nothing
    Exit Function

IsExcelOpenErr:
    IsExcelOpen = False
    Err.Clear
    Resume IsExcelOpenBye
End Function


Всё то же самое, но сохраняем модифицированный файл с другим названием

Public Function MSExcel_MarkFirstRowAndSave(wbSoursePath As String, wbDistPath As String) As Long
'es - 09.12.2016
'Вставляет загоровки столбцов в файл Excel (wbSoursePath) и сохраняет его как wbDistPath
'При ошибке - возвращает её код
'---------------------------------------------------------------------------------------
'Аргументы:
'   wbSoursePath  = Исходный файл
'   wbDistPath    = Модифицированный файл (по умолчанию = wbSoursePath)
'---------------------------------------------------------------------------------------
Dim objExcelApp As Object 'Excel.Application
Dim objWorkbook As Object 'Excel.Workbook
Dim AppIsRunning As Boolean
'---------------------------------------------------------------------------------------
On Error GoTo MSExcel_MarkFirstRowAndSaveErr
    AppIsRunning = IsExcelOpen
    If AppIsRunning = False Then
        Set objExcelApp = CreateObject("Excel.Application")
    Else
        Set objExcelApp = GetObject(, "Excel.Application")
    End If
    
    Set objWorkbook = objExcelApp.Workbooks.Open(wbSoursePath)
    'objExcelApp.Visible = True
    
    With objWorkbook.Worksheets(1)
    'Добавляем одну строку вверх листа 1:
        .Rows(1).Insert                    'Добавляем одну строку над первой
        .Rows(1).RowHeight = 18            'Выставляем высоту новой строки
        .Columns("A:A").ColumnWidth = 60   'Выставляем ширину первого столбца строки
        .Range("A1").Select                'Переход в начало листа
    
    'Пищем заголовки столбцов в первую строку ....
        .Range("A1").FormulaR1C1 = "prCode"
        .Range("B1").FormulaR1C1 = "prName"
        .Range("C1").FormulaR1C1 = "prStore"
        .Range("D1").FormulaR1C1 = "prPrice"
        .Range("E1").FormulaR1C1 = "prQTY"
        .Range("F1").FormulaR1C1 = "prNotes"
    ' ... и т.д. ...
    End With
'---------------------------------------------------------------------------------------
'Сохраняем РЕЗУЛЬТАТ в новом файле
    ' см. : https://msdn.microsoft.com/en-us/library/bb241279(v=office.12).aspx
    objWorkbook.SaveAs wbDistPath, 39 'xlExcel7= 39  или  xlExcel8 = 56

    'objWorkbook.SaveAs wbDistPath
    DoEvents
    
MSExcel_MarkFirstRowAndSaveBye:  'Закрываем всё!
    On Error Resume Next
    objWorkbook.Close
    Set objWorkbook = Nothing
    'Если Excel запускали сами ..
    If AppIsRunning = False Then objExcelApp.Quit
    Set objExcelApp = Nothing
    Err.Clear
    Exit Function

MSExcel_MarkFirstRowAndSaveErr:
    MSExcel_MarkFirstRowAndSave = Err.Number
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure MSExcel_MarkFirstRowAndSave", vbCritical, "Error!"
    Resume MSExcel_MarkFirstRowAndSaveBye
End Function


Назад ToTop
L.E. 09.12.2016
Рейтинг@Mail.ru