-
Notifications
You must be signed in to change notification settings - Fork 0
/
export.bas
81 lines (63 loc) · 2.64 KB
/
export.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Attribute VB_Name = "export"
Sub ExportAndFormatExcel()
Dim projectPath As String
Dim projectName As String
Dim exportFilePath As String
Dim exportMapName As String
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlWorksheet As Object
Dim lastRow As Long
Dim i As Long
' Получить путь и имя текущего файла проекта
projectPath = ActiveProject.Path
projectName = ActiveProject.Name
' Формирование пути для сохранения экспортированного файла Excel рядом с mpp файлом
exportFilePath = projectPath & "\" & Replace(projectName, ".mpp", "_экспорт.xlsx")
' Название схемы экспорта
exportMapName = "Экспорт ГПР test"
' Удалить существующий файл, если он есть
On Error Resume Next
Kill exportFilePath
On Error GoTo 0
' Экспортировать данные с использованием существующей схемы экспорта
FileSaveAs Name:=exportFilePath, _
FormatID:="MSProject.ACE", _
map:=exportMapName
' Открыть файл Excel
Set xlApp = CreateObject("Excel.Application")
Set xlWorkbook = xlApp.Workbooks.Open(exportFilePath)
Set xlWorksheet = xlWorkbook.Sheets(1)
' Получить последнюю заполненную строку в столбце C
lastRow = xlWorksheet.Cells(xlWorksheet.Rows.Count, "C").End(-4162).Row ' xlUp
' Форматирование столбцов дат
With xlWorksheet
' Установить формат ячеек для столбцов C, D, H, I
.Range("C2:C" & lastRow).NumberFormat = "dd.mm.yyyy"
.Range("D2:D" & lastRow).NumberFormat = "dd.mm.yyyy"
.Range("H2:H" & lastRow).NumberFormat = "dd.mm.yyyy"
.Range("I2:I" & lastRow).NumberFormat = "dd.mm.yyyy"
' Обновить значения ячеек
For i = 2 To lastRow
' Прочитать значение ячейки и преобразовать его в нужный формат
Dim oldValue As Date
oldValue = .Cells(i, "C").Value
.Cells(i, "C").Value = oldValue
oldValue = .Cells(i, "D").Value
.Cells(i, "D").Value = oldValue
oldValue = .Cells(i, "H").Value
.Cells(i, "H").Value = oldValue
oldValue = .Cells(i, "I").Value
.Cells(i, "I").Value = oldValue
Next i
End With
' Сохранить и закрыть файл
xlWorkbook.Save
xlWorkbook.Close
' Очистить объекты Excel
Set xlWorksheet = Nothing
Set xlWorkbook = Nothing
Set xlApp = Nothing
' Сообщение об успешном экспорте
MsgBox "Проект экспортирован и отформатирован в " & exportFilePath
End Sub