vba小技巧

日常工作中，熟练的使用vba会极大的帮助俺们提高工作效率。这一点在俺进入队日外包这个行当后更是深有体会。下面是一些小技巧，希望可以给感兴趣的朋友一些帮助。

1、解除Sheet保护
ActiveSheet.Unprotect "密码" 

2、拷贝模扳sheet生成新文档
Sub CreateExcel()
    Dim tempSheet As Worksheet
    Set tempSheet = Application.Workbooks("Templete2.xls").Worksheets(1)
    Dim strPageId As String
    Dim strPageName As String
    Dim intRow As Integer
    Dim intCol As Integer
    Dim dataWorkBook As Workbook
    Set dataWorkBook = ActiveWorkbook
    intRow = 3
    intCol = 1
    strPageId = Trim(dataWorkBook.ActiveSheet.Cells(intRow, intCol))
    strPageName = Trim(dataWorkBook.ActiveSheet.Cells(intRow, intCol + 1))
   
    Dim tmpWorkBook As Workbook
    Set tmpWorkBook = Application.Workbooks.Add
       
   
    'tmpWorkBook.SaveAs Filename:=dataWorkBook.Path & "/" & dataWorkBook.Name & ".xls"
    Do Until (strPageId = "")
       
        tempSheet.Copy After:=tmpWorkBook.Worksheets(tmpWorkBook.Worksheets.Count)
        tmpWorkBook.Worksheets(tmpWorkBook.Worksheets.Count).Range("B1").Value = strPageName & "「" & strPageId & "」"
        tmpWorkBook.Worksheets(tmpWorkBook.Worksheets.Count).Name = strPageId
        intRow = intRow + 1
        strPageId = Trim(dataWorkBook.ActiveSheet.Cells(intRow, intCol))
        strPageName = Trim(dataWorkBook.ActiveSheet.Cells(intRow, intCol + 1))
    Loop
    Application.DisplayAlerts = False
    tmpWorkBook.Worksheets(1).Delete
    tmpWorkBook.Worksheets(1).Delete
    tmpWorkBook.Worksheets(1).Delete
    Application.DisplayAlerts = True
    tmpWorkBook.Close True, dataWorkBook.Path & "/" & dataWorkBook.ActiveSheet.Name & ".xls"
    Set tmpWorkBook = Nothing
    dataWorkBook.Activate
End Sub

3、在Excel中插入图像文件
      .Cells(PicRow(RowIdx), PicCol(ColIdx)).Activate
      .Pictures.Insert FileName:=FilePath, converter:=xlTIF

4、打开选择文件对话窗口
Application.GetOpenFilename(FileFilter:="", MultiSelect:=False)

5、保护Sheet不能更改
ActiveSheet.Protect PassWord:="密码", DrawingObjects:=True, Contents:=True, Scenarios:=True

6、由汉字获取拼音的一个例子（转载）
Option Explicit
Private Const IME_ESC_MAX_KEY = &H1005
Private Const IME_ESC_IME_NAME = &H1006
Private Const GCL_REVERSECONVERSION = &H2
Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As 
Long) As Long
Private Declare Function ImmEscape Lib "imm32.dll" Alias "ImmEscapeA" (ByVal hkl As Long, ByVal
himc As Long, ByVal un As Long, lpv As Any) As Long
Private Declare Function ImmGetConversionList Lib "imm32.dll" Alias "ImmGetConversionListA" 
(ByVal hkl As Long, ByVal himc As Long, ByVal lpsz As String, lpCandidateList As Any, ByVal 
dwBufLen As Long, ByVal uFlag As Long) As Long
Private Declare Function IsDBCSLeadByte Lib "kernel32" (ByVal bTestChar As Byte) As Long
Public Function GetChineseSpell(Chinese As String, Optional Delimiter As String = " ", Optional
IMEName As String = "微软拼音输入法", Optional BufferSize As Long = 255) As String
If VBA.Len(VBA.Trim(Chinese)) > 0 Then
Dim i As Long
Dim s As String
s = VBA.Space(BufferSize)
Dim IMEInstalled As Boolean
Dim j As Long
Dim a() As Long
ReDim a(BufferSize) As Long
j = GetKeyboardLayoutList(BufferSize, a(LBound(a)))
 
  
For i = LBound(a) To LBound(a) + j - 1
   If ImmEscape(a(i), 0, IME_ESC_IME_NAME, ByVal s) Then
     If VBA.Trim(IMEName) = VBA.Replace(VBA.Trim(s), VBA.Chr(0), "") Then
      IMEInstalled = True
      Exit For
     End If
   End If
Next i
If IMEInstalled Then
   'Stop
   Chinese = VBA.Trim(Chinese)
   Dim sChar As String
   Dim Buffer0() As Byte
   'Dim Buffer() As Byte
   Dim bBuffer0() As Byte
   Dim bBuffer() As Byte
   Dim k As Long
   Dim l As Long
   Dim m As Long
   For j = 0 To VBA.Len(Chinese) - 1
     sChar = VBA.Mid(Chinese, j + 1, 1)
     Buffer0 = VBA.StrConv(sChar, vbFromUnicode)
     If IsDBCSLeadByte(Buffer0(0)) Then
      k = ImmEscape(a(i), 0, IME_ESC_MAX_KEY, Null)
      If k Then
        l = ImmGetConversionList(a(i), 0, sChar, 0, 0, GCL_REVERSECONVERSION)
        If l Then
         s = VBA.Space(BufferSize)
         If ImmGetConversionList(a(i), 0, sChar, ByVal s, l, GCL_REVERSECONVERSION) Then
           
           bBuffer0 = VBA.StrConv(s, vbFromUnicode)
           ReDim bBuffer(k * 2 - 1)
           For m = bBuffer0(24) To bBuffer0(24) + k * 2 - 1
             bBuffer(m - bBuffer0(24)) = bBuffer0(m)
           Next m
           sChar = VBA.Trim(VBA.StrConv(bBuffer, vbUnicode))
           If VBA.InStr(sChar, vbNullChar) Then
            sChar = VBA.Trim(VBA.Left(sChar, VBA.InStr(sChar, vbNullChar) - 1))
           End If
           sChar = VBA.Left(sChar, VBA.Len(sChar) - 1) & VBA.IIf(j < VBA.Len(Chinese) - 1, Delimiter, "")

End If

End If
End If
End If
GetChineseSpell = GetChineseSpell & sChar
Next j
Else

End If

End If
End Function
Private Sub Command1_Click()
VBA.MsgBox GetChineseSpell("我是")
End Sub

7、关闭Excel文件时不提示保存对话框
将WorkBook的Saved属性设为True

8、关闭当前Excel文件，并保存
ActiveWorkbook.Close savechanges:=True
Application.Quit

9、导出ACCESS中的表的信息
Option Compare Database

Sub createInfo()
    Dim myTableDefs As TableDefs
    Dim tempTableDef As TableDef
    Dim tempField As Field
    Dim myExcel As Excel.Application
    Dim myExcelBook As Excel.Workbook
    Dim workSheet As Excel.workSheet
    Dim tempFieldInfo   As FieldInfo
    Dim rowCount As Integer
    Set myExcel = New Excel.Application
    Set myExcelBook = myExcel.Workbooks.Add
   
    Set myTableDefs = Application.DBEngine.Workspaces(0).Databases(0).TableDefs
    For Each tableItem In myTableDefs
        Set tempTableDef = tableItem
        If (tempTableDef.Attributes = 0) Then
            Set workSheet = myExcelBook.Worksheets.Add
            workSheet.Name = tempTableDef.Name
            rowCount = 2
            For Each fieldItem In tempTableDef.Fields
                Set tempField = fieldItem
                Set tempFieldInfo = New FieldInfo
                With tempFieldInfo
                    .FieldName = tempField.Name
                    Select Case tempField.Type
                    Case dbBigInt: .FieldType = "Big Integer 型 (Big Integer)"
                    Case dbBinary: .FieldType = "バイナリ型 (Binary)"
                    Case dbBoolean: .FieldType = "ブール型 (Boolean)"
                    Case dbByte: .FieldType = "バイト型 (Byte)"
                    Case dbChar: .FieldType = "CHAR 型 (Char)"
                    Case dbCurrency: .FieldType = "通貨型 (Currency)"
                    Case dbDate: .FieldType = "日付/時刻型 (Date/Time)"
                    Case dbDecimal: .FieldType = "10 進型 (Decimal)"
                    Case dbDouble: .FieldType = "倍精度浮動小数点数型 (Double)"
                    Case dbFloat: .FieldType = "浮動小数点数型 (Float)"
                    Case dbGUID: .FieldType = "GUID 型 (GUID)"
                    Case dbInteger: .FieldType = "整数型 (Integer)"
                    Case dbLong: .FieldType = "長整数型 (Long)"
                    Case dbLongBinary: .FieldType = "ロング バイナリ型 (LongBinary) - OLE オブジェクト型 (OLE Object)"
                    Case dbMemo: .FieldType = "メモ型 (Memo)"
                    Case dbNumeric: .FieldType = "Numeric 型 (Numeric)"
                    Case dbSingle: .FieldType = "単精度浮動小数点数型 (Single)"
                    Case dbText: .FieldType = "テキスト型 (Text)"
                    Case dbTime: .FieldType = "時刻型 (Time)"
                    Case dbTimeStamp: .FieldType = "タイムスタンプ型 (TimeStamp)"
                    Case dbVarBinary: .FieldType = "可変長バイナリ型 (VarBinary)"
                    End Select

                    .FieldSize = tempField.Size
                    For i = 0 To tempField.Properties.Count - 1
                        If (tempField.Properties(i).Name = "Description") Then
                            .FieldDescription = tempField.Properties(i).Value
                        End If
                    Next
                End With
                With tempFieldInfo
                    workSheet.Cells(rowCount, 2) = .FieldDescription
                    workSheet.Cells(rowCount, 3) = .FieldName
                    workSheet.Cells(rowCount, 4) = .FieldType
                    workSheet.Cells(rowCount, 5) = .FieldSize
                End With

                rowCount = rowCount + 1
            Next
            Call SetTitle(workSheet)
            Call SetFormat(workSheet, 1, 1, rowCount, 5)
        End If
    Next
    myExcel.DisplayAlerts = False
    myExcelBook.Sheets(myExcelBook.Sheets.Count).Delete
    myExcelBook.Sheets(myExcelBook.Sheets.Count).Delete
    myExcelBook.Sheets(myExcelBook.Sheets.Count).Delete
    myExcelBook.SaveAs "e:/info.xls"
    myExcelBook.Close 'SaveChanges:=True, Filename:="e:/info.xsl"
    myExcel.DisplayAlerts = True
    myExcel.Quit
    Set myExcel = Nothing
End Sub

Private Sub SetTitle(myWorkSheet As Excel.workSheet)
    myWorkSheet.Cells(1, 1) = "項番"
    myWorkSheet.Cells(1, 2) = "項  目  名  称（日本語）"
    myWorkSheet.Cells(1, 3) = "項  目  名  称（記号名）"
    myWorkSheet.Cells(1, 4) = "属性"
    myWorkSheet.Cells(1, 5) = "桁数"
   
    myWorkSheet.Columns("A:A").ColumnWidth = 10
    myWorkSheet.Columns("B:B").ColumnWidth = 20
    myWorkSheet.Columns("C:C").ColumnWidth = 15
    myWorkSheet.Columns("D:D").ColumnWidth = 10
    myWorkSheet.Columns("E:E").ColumnWidth = 10
End Sub

Private Sub SetFormat(myWorkSheet As Excel.workSheet, _
                    startRow As Integer, startCol As Integer, _
                    endRow As Integer, endCol As Integer)
    Dim myRange As Range
    Set myRange = myWorkSheet.Range(myWorkSheet.Cells(startRow, startCol), myWorkSheet.Cells(endRow, endCol))
    myRange.Borders(xlDiagonalDown).LineStyle = xlNone
    myRange.Borders(xlDiagonalUp).LineStyle = xlNone
    With myRange.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myRange.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myRange.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myRange.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myRange.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With myRange.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub

class---------------- FieldInfo
Option Compare Database

Public FieldName As String
Public FieldType As String
Public FieldSize As String
Public FieldDescription As String

10、显示或隐藏整行
''隐藏
Selection.EntireRow.Hidden = True
'显示
Selection.EntireRow.Hidden = False

11、设置Excel的自动运行
在模块中编写 auto_open 就可以了！

12、调用Excel，并插入图片
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open FileName:=XLSPATH_SINNYU & XLFILE_NAME
objExcel.Visible = True
Set objWS = objExcel.ActiveSheet
objWS.Pictures.Insert( _
        "C:/Documents and Settings/All Users/Documents/My Pictures/Sample Pictures/Sunset.jpg" _
        ).Select
objExcel.Selection.ShapeRange.Height = 107.25
objWS.PrintOut
objExcel.ActiveWorkbook.Close savechanges:=False
objExcel.Application.Quit
Set objExcel = Nothing