Блог программиста Еремина Вячеслава Викторовича

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.



Комментарии к этой страничке ( )
ссылка на эту страничку: http://vb-net.ru/VBA/index.htm
<Назад>  <На главную>  <В раздел ASP>  <В раздел NET>  <В раздел SQL>  <В раздел Разное>  <Написать автору>  < Поблагодарить>