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