EXCEL宏编程纪念

        不久前被叫去编写宏,这EXCEL宏真是麻烦! 可能以后不会再遇到有编写宏的经历了,故而贴出来以做个纪念:

 Sub direct_Price()
'
'query_dir_volume
'宏由 颜清国编写,时间: 2007-4-9
'
''定义变量
Dim cRows As Integer '总行数
Dim cColumns As Integer '总列数
Dim HEADERCOLORINDEX As Integer  '表头的背景色
Dim cTemp As Integer  '临时计数
Dim sTempString As String  '临时字符串变量
Dim i As Integer  '临时计数
Dim j As Integer  '临时计数
Dim rowIndex As Integer  '临时指示处理到哪里
Dim colIndex As Integer  '临时指示处理到哪里
Dim tempRndColor As Integer  '临时生成的颜色
Dim TABLENAME As String  '待处理的表名

Dim colorIndex As String  '颜色索引名字

''''''''''''''''''''''''''''''''''''''''''''''

'表头的背景色
HEADERCOLORINDEX = 15

colorIndex = 36 '颜色从33开始是比较浅的颜色

TABLENAME = "direct_Price"
'关闭所有弹出的警告消息
Application.DisplayAlerts = False

'设置需要处理的单元表
Sheets(TABLENAME).Select

 '取单元表的总列数与总行数
cRows = Sheets(TABLENAME).UsedRange.Rows.Count
cColumns = Sheets(TABLENAME).UsedRange.Columns.Count
   
''''''''''''''''''''''''''''''''''''''''''''''


   
     '选择所有的单元格
 Range(Cells(1, 1), Cells(cRows, cColumns)).Select
 
   '设置该表中所有单元行高为11.25
 Selection.RowHeight = 11.25
 

   
'设置该表中所有单元行高为11.25
 Selection.RowHeight = 11.25
 
 '设置所有的边框
 Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
   
   '并且拆分所有的单元格
 With Selection
        .MergeCells = False '拆分单格
 End With
 
 Columns("C:C").Select
 Selection.Insert Shift:=xlToRight
 
  '删除第一列,注意这里必须先拆分单格,再删除第一列,否则一次就会把合并单元格所在列全部删除
 Range(Cells(1, 1), Cells(1, 1)).Select
 Selection.EntireColumn.Delete
 'Selection.EntireColumn.Delete
 
   '向表头添加一行
  Rows("1:1").Select
  Selection.Insert
 
 
Columns("A:A").Select
Selection.ColumnWidth = 9.29

Columns("B:B").Select
Selection.ColumnWidth = 6.71

Columns("C:C").Select
Selection.ColumnWidth = 15.29

Columns("D:D").Select
Selection.ColumnWidth = 29.86

Columns("E:E").Select
Selection.ColumnWidth = 12.29

Columns("F:F").Select
Selection.ColumnWidth = 12.29


   
    '''''''''''''''''''''''''''''''''''设定单元格A1:A2''''''''''''''''''''
     '合并A1:A2单元格
    Range("A1:A2").Select
   
    '将数据写回
     With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
   
    '往该单元格中写入Usage_Var
    ActiveCell.FormulaR1C1 = "Price"
   
   
    '设置该单元格字体格式
    With ActiveCell.Characters(Start:=1, Length:=5).Font
        .Name = "Arial"
        .FontStyle = "加粗 倾斜"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = 2
    End With
   
    '单元格设定边框
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = 56
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
   
    With Selection.Interior
        .colorIndex = 5
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
   
  '''''''''''''''''''''''''''''设定头两行的内部样式'''''''''''''''''''''''
    
     Range("B1:B2").Select
     Selection.Merge
   
     Range("C1:C2").Select
    Selection.Merge
    
     Range("D1:D2").Select
     Selection.Merge
    
    
    Range("B1:D2").Select
   
  '设置头两行行高为11.25
   Selection.RowHeight = 14.25
  
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = xlAutomatic
    End With
   
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
   
    With Selection.Interior
        .colorIndex = HEADERCOLORINDEX
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
   
   
    Range("B1:B2").Select
    ActiveCell.FormulaR1C1 = "Type"
    With ActiveCell.Characters(Start:=1, Length:=4).Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = 5
    End With
   
   
     Range("E1:F1").Select
         With Selection.Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = 5
    End With
   With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
   
    With Selection.Interior
        .colorIndex = HEADERCOLORINDEX
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
     ActiveCell.FormulaR1C1 = "Price"
    
    Range("E2:F2").Select
   
  '设置头两行行高为11.25
   Selection.RowHeight = 14.25
  
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = xlAutomatic
    End With
   
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
    With Selection.Interior
        .colorIndex = HEADERCOLORINDEX
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
   
   
    '加第一二行边框
    Range("A1:F2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
  
  
    '去掉第三行的:号
    'sTempString = Right(Cells(3, 1), Len(Cells(3, 1)) - 3)
    'ActiveCell.FormulaR1C1 = sTempString
   
    i = 2
    j = 1
    
   '外层循环判断是否都合并完成,这里插入了一行,加1
   While i <= cRows
   ' i = i + 1
   
     Range(Cells(i + 1, j), Cells(i + 1, j)).Select
    
    '去掉分类行中的:号
    If (Len(Cells(i + 1, j)) >= 3) Then
      ''''''''''''''如果是分格的界限''''''''''''''''''''''''''''''''''''
      If (Left(Cells(i + 1, j), 3) = " : ") Then
     
          Range(Cells(i + 1, j), Cells(i + 1, cColumns)).Select
         
        '对第三行进行设定
        '设置头两行行高为11.25
        Selection.RowHeight = 18
      With Selection.Interior
         .colorIndex = 2
         .Pattern = xlSolid
         .PatternColorIndex = xlAutomatic
       End With
       '合并前两格
       '先将其合并
      With Selection
        .HorizontalAlignment = xlLeft '靠左对齐
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
       End With
    '合并
     Selection.Merge
    
    '对其设定字体风格
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "加粗 倾斜"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = 3
    End With
   
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
   
        sTempString = Right(Cells(i + 1, j), Len(Cells(i + 1, j)) - 3)
        ActiveCell.FormulaR1C1 = sTempString
        i = i + 1
      End If
    End If
 
 
    i = i + 1
   
    '加1后判断是否到了表尾,没有继续合并处理
    'If (i <= cRows + 1) Then
   
     rowIndex = i
     '取出Cells(i, j)的内容
    sTempString = Cells(i, j)
   
    '循环判断下一个单元格是否和上一个单元格相等,不是则表示到此该合并
   While sTempString = Cells(i + 1, j) And i <= cRows
     i = i + 1
   Wend
  
  
   ''''''''''''''''''''''''''''''''''''设置第一列''''''''''''''''''''''''''''''''''''''''
   '跳出循环表示已经到此该将rowIndex 和 i行合并
   Range(Cells(rowIndex, j), Cells(i, j)).Select
   Selection.Merge
 
    '将原来内容填充进来
    ActiveCell.FormulaR1C1 = sTempString
   '设合并后的单元格的边框
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = True
    End With
    Selection.Font.FontStyle = "加粗"
        
     ''''''''''''''''''''''''''''''''''''设置第一列结束''''''''''''''''''''''''''''''''''''''''

     '''''''''''''''''''''''''''''''''''''''设置第二列'''''''''''''''''''''''''''''''''''''''''''''
     Range(Cells(rowIndex, j + 1), Cells(i, j + 1)).Select
          '设置字体
    
     With Selection.Font
     .Name = "Arial"
     .FontStyle = "加粗"
     .Size = 8
     .Strikethrough = False
     .Superscript = False
     .Subscript = False
     .OutlineFont = False
     .Shadow = False
     .Underline = xlUnderlineStyleNone
     .colorIndex = 5
     End With
   
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
   
     Selection.Borders(xlDiagonalDown).LineStyle = xlNone
     Selection.Borders(xlDiagonalUp).LineStyle = xlNone
     With Selection.Borders(xlEdgeLeft)
         .LineStyle = xlContinuous
         .Weight = xlThin
         .colorIndex = 56
     End With
     With Selection.Borders(xlEdgeTop)
         .LineStyle = xlContinuous
         .Weight = xlThin
         .colorIndex = 56
     End With
     With Selection.Borders(xlEdgeBottom)
         .LineStyle = xlContinuous
         .Weight = xlThin
         .colorIndex = 56
     End With
     With Selection.Borders(xlEdgeRight)
         .LineStyle = xlContinuous
         .Weight = xlThin
         .colorIndex = 56
     End With
     Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    
    
'''''''''''''''''''''''''''''设置第二列结束'''''''''''''''''''''''''''''''''''''''''''''
  
'''''''''''''''''''''''''修改原来单元格的数据格式''''''''''''''''''''''''''''''''
''''''''''''''''''''''''首先向任一无用的单元格写入数据
   Range(Cells(cRows + 2, cColumns), Cells(cRows + 2, cColumns)).Select
   ActiveCell.FormulaR1C1 = "1"
   '将其格式拷贝
   Selection.Copy
  '复制格式
   Range(Cells(rowIndex, j + 4), Cells(i, cColumns)).Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
   SkipBlanks:=False, Transpose:=False
   Selection.NumberFormatLocal = "_*#,##0.00000"
   '清除原来内容
   Range(Cells(cRows + 2, cColumns), Cells(cRows + 2, cColumns)).Select
   Selection.ClearContents

''''''''''''''''''''''''设定数据格式完成''''''''''''''''''''''''''''''''''''''''''''''


 '''''''''''''''''''''''''''''''''''''''统一设置该区域的颜色''''''''''''''''''''''''''''''''''''''''''''''
     '设置内部填充
     Range(Cells(rowIndex, j), Cells(i, cColumns)).Select
    
     colorIndex = colorIndex + 1
     If colorIndex > 39 Then
        colorIndex = 33
    End If
   
     With Selection.Interior
             .colorIndex = colorIndex '颜色
             .Pattern = xlSolid
             .PatternColorIndex = xlAutomatic
     End With
 ''''''''''''''''''''''''''''''''''统一设置该区域的颜色结束''''''''''''''''''''''''''''''''''''''''''''''
 

'''''''''''''''''''''''''''''设置剩余的列'''''''''''''''''''''''''''''''''''''''''''''
    Range(Cells(rowIndex, j + 2), Cells(i, cColumns)).Select
   
    '设置字体
   With Selection.Font
      .Name = "Arial"
      .FontStyle = "常规"
      .Size = 8
      .Strikethrough = False
       .Superscript = False
      .Subscript = False
     .OutlineFont = False
       .Shadow = False
     .Underline = xlUnderlineStyleNone
     .colorIndex = xlAutomatic
     End With
    
    '设置第6列
    Range(Cells(rowIndex, j + 4), Cells(i, j + 5)).Select
          '设置字体
     With Selection.Font
      .Name = "Arial"
      .FontStyle = "常规"
      .Size = 8
      .Strikethrough = False
       .Superscript = False
      .Subscript = False
     .OutlineFont = False
       .Shadow = False
     .Underline = xlUnderlineStyleNone
     .colorIndex = 3
     End With
    
    
         
    '''''''''''''''''''''''''''''设置全部的边框'''''''''''''''''''''''''''''''''''''''''''''
    Range(Cells(rowIndex, j), Cells(i, cColumns)).Select
    '设置边框
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
      '  .LineStyle = xlContinuous
        .Weight = xlThin
       ' .colorIndex = xlAutomatic
    End With
Wend


 Range(Cells(rowIndex - 1, 1), Cells(rowIndex - 1, cColumns)).Select
 Selection.MergeCells = False
 
 
 Range(Cells(rowIndex - 1, cColumns - 1), Cells(rowIndex - 1, cColumns - 1)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = xlAutomatic
    End With
    With Selection.Interior
        .colorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    ActiveCell.FormulaR1C1 = "Average"
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = xlAutomatic
    End With
   
    Range(Cells(rowIndex - 1, cColumns), Cells(rowIndex - 1, cColumns)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = xlAutomatic
    End With
    With Selection.Interior
        .colorIndex = 15
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    ActiveCell.FormulaR1C1 = "Average"
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Arial"
        .FontStyle = "加粗"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .colorIndex = xlAutomatic
    End With
    
    
    Range(Cells(rowIndex - 1, cColumns - 1), Cells(rowIndex - 1, cColumns)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .colorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
       ' .LineStyle = xlContinuous
        .Weight = xlThin
       ' .colorIndex = xlAutomatic
    End With
   
End Sub

 




 

你可能感兴趣的:(编程,F#,Excel,J#)