VBA - язык автоматизации Excel
Однажды мне пришлось загнать в базу несколько сотен первичных Excel-документов. Все документы были слегка по разному отформатированы - у одних табличек было в шапке две строчки, у других три. Одни таблички были длиной 44 строки, другие 47.
Для автоматизации этой операции я создал вот такой простейший гавнокод:
1: Attribute VB_Name = "Module1"
2: Sub Book_ini()
3: Attribute Book_ini.VB_ProcData.VB_Invoke_Func = "i\n14"
4: '
5: ' Макрос9 Макрос
6: ' Макрос записан 26/03/2002 (Administrator)
7: '
8: ' Сочетание клавиш: Ctrl+i
9: '
10: Cells.Select
11: With Selection
12: .VerticalAlignment = xlBottom
13: .WrapText = False
14: .Orientation = 0
15: .AddIndent = False
16: .ShrinkToFit = False
17: .ReadingOrder = xlContext
18: .MergeCells = False
19: End With
20: Columns("A:A").Select
21: Selection.Insert Shift:=xlToRight
22: Columns("C:C").Select
23: Selection.Insert Shift:=xlToRight
24: Selection.Insert Shift:=xlToRight
25: Columns("G:G").Select
26: Selection.Insert Shift:=xlToRight
27: Selection.Insert Shift:=xlToRight
28: Columns("K:K").Select
29: Selection.Insert Shift:=xlToRight
30: Selection.Insert Shift:=xlToRight
31: Cells.Select
32: Selection.ColumnWidth = 7.5
33: ActiveWorkbook.Save
34: Range("A1").Select
35: End Sub
36:
37: Sub Formula()
38: '
39: ' Макрос5 Макрос
40: ' Макрос записан 26/03/2002 (Administrator)
41: '
42: ' Сочетание клавиш: Ctrl+y
43: '
44: Range("O1").Select
45: ActiveCell.FormulaR1C1 = _
46: "INSERT INTO [Railway].[dbo].[RAW] ([Name],[Station],[Num],[Comment],[In],[Out]) VALUES ('"
47: '
48: Range("P1").Select
49: ActiveCell.FormulaR1C1 = _
50: "'','"
51: '
52: Range("Q1").Select
53: ActiveCell.FormulaR1C1 = _
54: "'');"
55: '
56: Range("R1").Select
57: ActiveCell.FormulaR1C1 = _
58: "=RC[-3]&RC[-17]&RC[-2]&RC[-16]&RC[-2]&RC[-15]&RC[-2]&RC[-14]&RC[-2]&RC[-13]&RC[-2]&RC[-12]&RC[-1]"
59: '
60: Range("S1").Select
61: ActiveCell.FormulaR1C1 = _
62: "=RC[-4]&RC[-18]&RC[-3]&RC[-17]&RC[-3]&RC[-12]&RC[-3]&RC[-11]&RC[-3]&RC[-10]&RC[-3]&RC[-9]&RC[-2]"
63: '
64: Range("T1").Select
65: ActiveCell.FormulaR1C1 = _
66: "=RC[-5]&RC[-19]&RC[-4]&RC[-18]&RC[-4]&RC[-9]&RC[-4]&RC[-8]&RC[-4]&RC[-7]&RC[-4]&RC[-6]&RC[-3]"
67: Range("T2").Select
68: '
69: End Sub
70:
71:
72: Sub Move_Num()
73: Attribute Move_Num.VB_ProcData.VB_Invoke_Func = "q\n14"
74: '
75: ' Макрос1 Макрос
76: ' Макрос записан 25/03/2002 (Administrator)
77: '
78: ' Сочетание клавиш: Ctrl+e
79: '
80:
81: Dim StartColumn As Integer
82: Dim StartRow As Integer
83: '
84: StartColumn = Selection.Column
85: StartRow = Selection.Row
86: '
87: If StartColumn <> 5 Then
88: Dim Ret As Integer
89: Ret = MsgBox("Вы уверены?", vbYesNo)
90: If Ret = vbNo Then Exit Sub
91: End If
92: '
93: Selection.Cut Destination:=Cells(StartRow + 5, StartColumn - 2)
94: Cells(StartRow + 1, StartColumn).Select
95: Selection.Cut Destination:=Cells(StartRow + 5, StartColumn - 1)
96: '
97: StartColumn = Selection.Column + 4
98: Cells(StartRow, StartColumn).Select
99: Selection.Cut Destination:=Cells(StartRow + 5, StartColumn - 2)
100: Cells(StartRow + 1, StartColumn).Select
101: Selection.Cut Destination:=Cells(StartRow + 5, StartColumn - 1)
102: '
103: StartColumn = Selection.Column + 4
104: Cells(StartRow, StartColumn).Select
105: Selection.Cut Destination:=Cells(StartRow + 5, StartColumn - 2)
106: Cells(StartRow + 1, StartColumn).Select
107: Selection.Cut Destination:=Cells(StartRow + 5, StartColumn - 1)
108:
109: End Sub
110:
111: Sub Fill47()
112: Attribute Fill47.VB_ProcData.VB_Invoke_Func = "w\n14"
113: '
114: ' Макрос3 Макрос
115: ' Макрос записан 25/03/2002 (Administrator)
116: '
117: ' Сочетание клавиш: Ctrl+r
118: '
119: MyFill 47
120:
121: End Sub
122:
123: Sub Fill44()
124:
125: MyFill 44
126:
127: End Sub
128:
129:
130: Sub MyFill(FillRows As Integer)
131:
132: Dim StartColumn As Integer
133: Dim StartRow As Integer
134: '
135: StartColumn = Selection.Column
136: StartRow = Selection.Row
137: '
138: If StartColumn <> 3 Then
139: Dim Ret As Integer
140: Ret = MsgBox("Вы уверены?", vbYesNo)
141: If Ret = vbNo Then Exit Sub
142: End If
143: '
144: Cells(StartRow, StartColumn).Select
145: Selection.AutoFill Destination:=Range(Cells(StartRow, StartColumn), Cells(StartRow + FillRows - 1, StartColumn)), Type:=xlFillCopy
146: '
147: StartColumn = StartColumn + 1
148: Cells(StartRow, StartColumn).Select
149: Selection.AutoFill Destination:=Range(Cells(StartRow, StartColumn), Cells(StartRow + FillRows - 1, StartColumn)), Type:=xlFillCopy
150: '
151: StartColumn = StartColumn + 3
152: Cells(StartRow, StartColumn).Select
153: Selection.AutoFill Destination:=Range(Cells(StartRow, StartColumn), Cells(StartRow + FillRows - 1, StartColumn)), Type:=xlFillCopy
154: '
155: StartColumn = StartColumn + 1
156: Cells(StartRow, StartColumn).Select
157: Selection.AutoFill Destination:=Range(Cells(StartRow, StartColumn), Cells(StartRow + FillRows - 1, StartColumn)), Type:=xlFillCopy
158: '
159: StartColumn = StartColumn + 3
160: Cells(StartRow, StartColumn).Select
161: Selection.AutoFill Destination:=Range(Cells(StartRow, StartColumn), Cells(StartRow + FillRows - 1, StartColumn)), Type:=xlFillCopy
162: '
163: StartColumn = StartColumn + 1
164: Cells(StartRow, StartColumn).Select
165: Selection.AutoFill Destination:=Range(Cells(StartRow, StartColumn), Cells(StartRow + FillRows - 1, StartColumn)), Type:=xlFillCopy
166:
167: End Sub
Этим гавнокодом мне удалось решить вопрос чтения около сотни первичных Excel-документов в SQL не за год, а за день. Такого выхлопа на одну строчку кода желаю и вам.
Вот еще пример такого же удачного кода, который выполняет преобразование прайса из одного формата в другой и затем заменяет разделители в итоговом файле CSV:
1: Attribute VB_Name = "Convert"
2: Sub Start()
3:
4: Dim SourceFileName As String, TargetFileName As String
5: SourceFileName = Workbooks(1).FullName
6: Set SourceSheet = Workbooks(1).ActiveSheet
7: '
8: Dim NewWorkBooks As Workbook
9: Set NewWorkBooks = Workbooks.Add
10: Set TargetSheet = NewWorkBooks.ActiveSheet
11: '
12: TargetSheet.Cells(1, 1) = "Название раздела"
13: TargetSheet.Cells(1, 2) = "Название раздела"
14: TargetSheet.Cells(1, 3) = "Название раздела"
15: TargetSheet.Cells(1, 4) = "Артикул товара"
16: TargetSheet.Cells(1, 5) = "Код товара"
17: TargetSheet.Cells(1, 6) = "Путь к товару"
18: TargetSheet.Cells(1, 7) = "Название товара"
19: TargetSheet.Cells(1, 8) = "Производитель товара"
20: TargetSheet.Cells(1, 9) = "Название производителя"
21: TargetSheet.Cells(1, 10) = "Описание товара"
22: TargetSheet.Cells(1, 11) = "Текст для товара"
23: TargetSheet.Cells(1, 12) = "Цена"
24: TargetSheet.Cells(1, 13) = "Склад в Москве"
25: TargetSheet.Cells(1, 14) = "Склад в Коломне"
26: TargetSheet.Cells(1, 15) = "Склад офис Москва"
27: TargetSheet.Cells(1, 16) = "Ближайший приход"
28: TargetSheet.Cells(1, 17) = "Флаг Экспортировать в Яндекс.Маркет"
29: TargetSheet.Cells(1, 18) = "Файл изображения для товара"
30: TargetSheet.Cells(1, 19) = "Файл малого изображения для товара"
31: '
32: Dim i As Long, j As Long, k As Long, Zagol As Integer
33: k = 1 'номер строки в целевой таблице
34: Zagol = 21 'сколько отрезать шапки
35: 'пробежались после заголовка до максимального количества строк в прайсе
36: For i = Zagol To 20000
37: If SourceSheet.Cells(i, 4) <> "" Then
38: 'отрезали строки с заголовками
39: k = k + 1
40:
41: TargetSheet.Cells(k, 1) = "Игрушки для детей"
42: TargetSheet.Cells(k, 2) = SourceSheet.Cells(i, 1).Value
43: TargetSheet.Cells(k, 3) = SourceSheet.Cells(i, 2).Value
44: TargetSheet.Cells(k, 4) = SourceSheet.Cells(i, 3)
45: TargetSheet.Cells(k, 5) = SourceSheet.Cells(i, 3)
46: TargetSheet.Cells(k, 6) = SourceSheet.Cells(i, 3)
47: TargetSheet.Cells(k, 7) = SourceSheet.Cells(i, 5).Value
48: TargetSheet.Cells(k, 8) = SourceSheet.Cells(i, 6).Value
49: TargetSheet.Cells(k, 9) = SourceSheet.Cells(i, 6).Value
50: '
51: TargetSheet.Cells(k, 4).NumberFormat = "@"
52: TargetSheet.Cells(k, 5).NumberFormat = "@"
53: TargetSheet.Cells(k, 6).NumberFormat = "@"
54: '
55: If k > 150 Then
56: TargetSheet.Cells(k, 6).NumberFormat = "@"
57: End If
58: '
59: If IsNumeric(SourceSheet.Cells(i, 9).Value) Then
60: 'если в девятой клетке число (цена) - сделать наценку
61: TargetSheet.Cells(k, 12) = SourceSheet.Cells(i, 9).Value * 1.05
62: End If
63: 'наличие на складе
64: If SourceSheet.Cells(i, 11).Value <> "" Then
65: TargetSheet.Cells(k, 13) = 1
66: End If
67: If SourceSheet.Cells(i, 12).Value <> "" Then
68: TargetSheet.Cells(k, 14) = 1
69: End If
70: If SourceSheet.Cells(i, 13).Value <> "" Then
71: TargetSheet.Cells(k, 15) = 1
72: End If
73: '
74: If IsDate(SourceSheet.Cells(i, 14).Value) Then
75: TargetSheet.Cells(k, 16) = SourceSheet.Cells(i, 14).Value
76: Else
77: TargetSheet.Cells(k, 16) = "не ожидается"
78: End If
79: 'Флаг выгрузки в яндекс-маркет
80: If SourceSheet.Cells(i, 11).Value <> "" Or SourceSheet.Cells(i, 12).Value <> "" Or SourceSheet.Cells(i, 13).Value <> "" Then
81: TargetSheet.Cells(k, 17) = 1
82: End If
83: 'добавили столбцы с рисунками
84: Dim SourceURL As String, Pos1 As Integer, Pos2 As Integer, ImgName As String
85: If SourceSheet.Cells(i, 5).Hyperlinks.Count > 0 Then
86: SourceURL = SourceSheet.Cells(i, 5).Hyperlinks(1).Address
87: If SourceURL <> "" Then
88: Pos1 = InStr(1, SourceURL, "/medium/")
89: If Pos1 > 0 Then
90: ImgName = Right(SourceURL, Len(SourceURL) - Pos1 - 7)
91: TargetSheet.Cells(k, 18) = "http://83.222.2.140/images/large/" & ImgName
92: TargetSheet.Cells(k, 19) = "http://83.222.2.140/images/medium/" & ImgName
93: End If
94:
95: End If
96: End If
97: End If
98: Next
99: '
100: 'MsgBox "End converting"
101: '
102: 'TargetFileName = Replace(SourceFileName, ".xls", ".csv")
103: 'NewWorkBooks.SaveAs TargetFileName, xlCSV
104: '
105: 'этот хвост вместо простого сохранения нужен из-за нестандартного CSV-разделителя ";"
106: Dim FSO As Variant, FH As Variant, rRow As Range, rCell As Range, Srt1 As String
107: '
108: Set FSO = CreateObject("Scripting.FileSystemObject")
109: TargetFileName = Replace(SourceFileName, ".xls", ".csv")
110: '
111: If FSO.FileExists(TargetFileName) = True Then
112: FSO.DeleteFile TargetFileName, True
113: End If
114: '
115: Set FH = FSO.OpenTextFile(TargetFileName, 2, True)
116: '
117: For Each rRow In TargetSheet.UsedRange.Rows
118: For Each rCell In rRow.Cells
119: Srt1 = Srt1 & rCell.Value & ";"
120: Next
121: Srt1 = Left(Srt1, Len(Srt1) - 1)
122: FH.WriteLine (Srt1)
123: Srt1 = ""
124: Next
125: '
126: FH.Close
127: 'если с движком не будет ругаться, то для экономии памяти лучше закрыть книгу
128: 'NewWorkBooks.Close
129: End Sub
Еще посмотреть примеры живого кода на VBA (Visual Basic for Application) вы можете здесь - Избавляемся от Microsoft Reporting Services, здесь - Сценарии ADSI и здесь - Скрипты WSH.
Comments (
)
)
Link to this page:
//www.vb-net.com/VBA/index.htm
|
|