MS Excel - Вставляем (удаляем) заголовки столбцов в файл рабочей книги
Полезно перед импортом (подключением) данных Excel
Public Sub esCreateFirstROW_in_ExcelWB(wbSoursePath As String)
Dim objExcelApp As Object
Dim objWorkbook As Object
On Error GoTo esCreateFirstROW_in_ExcelWB_Err
Set objExcelApp = CreateObject("Excel.Application")
Set objWorkbook = objExcelApp.Workbooks.Open(wbSoursePath)
With objWorkbook.Worksheets(1)
.Rows(1).Insert
.Rows(1).RowHeight = 18
.Range("A1").Select
.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"
End With
objWorkbook.Save
DoEvents
esCreateFirstROW_in_ExcelWB_Bye:
On Error Resume Next
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)
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)
If objWorkbook.Worksheets(1).Range("A1").FormulaR1C1 <> "tDetCode" Then
MsgBox "В файле: " & vbCrLf & wbSoursePath & vbCrLf & "Первоя строка, заданного формата не обнаружена!", vbCritical, "Не тот файл!"
GoTo esDeleteFirstROW_in_ExcelWB_Bye
End If
objWorkbook.Worksheets(1).Rows(1).Delete -4162
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
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
Dim objExcelApp As Object
Dim objWorkbook As Object
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)
With objWorkbook.Worksheets(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
objWorkbook.SaveAs wbDistPath, 39
DoEvents
MSExcel_MarkFirstRowAndSaveBye:
On Error Resume Next
objWorkbook.Close
Set objWorkbook = Nothing
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
|