Excel开发VBA学习

1.合并字符串
A1&A2
2.拆分字符串
LEFT(A2,SEARCH("-",A2)-1)
3.下拉选项
Data->Data validation->List

1.在工具栏上显示开发选项

2.新建个Module就可以在几个sheet里共享变量

Public cn As New ADODB.Connection
Public strCn As String
Public strCom As String
Public rs As New ADODB.Recordset
Public Sub Init()
  Dim rs As New ADODB.Recordset
  strCn = "Provider=sqloledb;Database=testdb;Uid=sa;Pwd=password;data source=dbname"
  Set cn = Nothing
  cn = New ADODB.Connection
  cn.Open strCn
End Sub

Private Sub CommandButton1_Click()
 'o = MsgBox("B1:" & Range("b1").Text & Range("b1").Value, vbOKOnly, "test")
  Init
  strCom = "exec testsp 2"
  rs.Open strCom, cn, adOpenDynamic, adLockBatchOptimistic
  Sheet1.Cells(1, 1).CopyFromRecordset rs
cn.Close
End Sub

3.添加下拉列表选项

ComboBox1.Clear
For Each testList In Sheet2.Rows 'Sheet2.Range("A1", "A6")
    With ComboBox1
      .AddItem testList.Value
    End With
Next testList

4.在另一台电脑上，发现上面的连接数据库会发生错误

在open语句时总是提示说连接已经结束，后来将连接字符串改了下又可以

Public strConn As String, strSQL As String
Public conn As ADODB.Connection
Public Sub Init()
    Set conn = New ADODB.Connection
    '连接数据库的字符串
    strConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=sa;Password=pwd;Initial Catalog=DBname;Data Source=DBServer;Connect Timeout=720; "
    '打开数据库连接
    conn.Open strConn
     '该句和数据库连接字符串处的Connect Timeout=720，表示说如果语句运行时间很长，这两句可以延长vba的等待时间，没有这两句，vba往往会报查询超时。
    conn.CommandTimeout = 720
End Sub

普通查询语句没问题，可是执行存储过程，稍微复杂一点的就会报错，应用程序定义或对象定义错误，后来才发现是存储过程必须加上这么一句

感谢万能的百度！
SET NOCOUNT ON

[求助] VBA调用存储过程的问题，在线等
http://club.excelhome.net/thread-1179098-1-1.html

执行带参数的存储过程也可以这么写

Dim CN As New ADODB.Connection
Dim iCmd As ADODB.Command
Const conn = "Provider = SQLOLEDB;" & _
               "Data Source = DBServer;" & _
               "Initial Catalog = DBName;User ID =sa;Password = pwd;"
CN.Open conn
        Set iCmd = New ADODB.Command
        With iCmd
              .ActiveConnection = CN
              .CommandTimeout = 120
              .CommandType = adCmdStoredProc
              .CommandText = "zConvertLunarSolar"
              .Parameters.Refresh
              .Parameters("@iyear") = 1966
              .Parameters("@imon") = 5
              .Parameters("@iday") = 3
              .Parameters("@ihour") = 1
              .Parameters("@imin") = 20
              .Parameters("@IsLeapM") = False
              .Parameters("@ToLunar") = True
          
        End With
        Dim rs As New ADODB.Recordset
        Set rs = iCmd.Execute
        Sheet1.Cells(5, 5).CopyFromRecordset rs

5.含有VBA代码的Excel再次打开，代码居然全都不见了！坑爹啊！原来.xlsx是不支持保存含有这些宏,ActiveX的文件，需要保存为启用宏的工作簿。
另存为后，发现设计模式变为灰色，原来还要在文件里启动宏才可以正常工作！

6.VBA大多数语法跟VB.Net一样，但也有些许不同，真令人防不胜防

Split函数，str.Split(",")是错的,须写成Split(str,",")

Len函数，用法是Len(str)，不是str.Length

数组类型Variant可以通过Redim来设置可变下标，获取最大和最小下标是用函数UBound(arr),LBound(arr),不是arr.Count()
    Dim pos() As Variant
    ReDim pos(colCnt)

另外，二维数组，比如从recordset返回的值,UBound(arr, 1)是数组最大列个数,UBound(arr, 2)才是最大行个数
   GetArray = rs.GetRows

Function里面的返回值，不要写成return i , 而要写成functioinName = i

Call Sub，不能有括号，不然会报错

7.得到返回记录集的行数
Fields.Item是返回的列,RecordCount总是返回-1,查了下，说第三个参数是1或者3的时候就可以得到RecordCount
rs.Open strSQL, conn,adOpenStatic, adLockReadOnly
rs.Open strSQL, conn,adOpenKeyset, adLockReadOnly
可是后来改了还是返回-1，原来是需要设置游标参数
rs.CursorLocation = adUseClient

Public Function CopyFromSQL(ByVal strSQL As String, ByVal sheetName As String, ByVal range As String, ByVal hrow As Integer, ByVal hCol As Integer) As Integer
    Dim rs As New ADODB.Recordset
    rs.CursorLocation = adUseClient
    rs.Open strSQL, conn, adOpenKeyset, adLockReadOnly
    
    Sheets(sheetName).range(range).ClearContents
    Sheets(sheetName).range(range).Borders.LineStyle = xlNone
    Sheets(sheetName).range(range).Interior.Pattern = xlNone
    
    '行名
    Dim rowCnt As Integer, colCnt As Integer, iCol As Integer
    rowCnt = rs.RecordCount
    colCnt = rs.Fields.Count
    iCol = hCol
     For Each Item In rs.Fields
       Sheets(sheetName).Cells(hrow, iCol) = Item.name
       iCol = iCol + 1
     Next Item
     iCol = iCol - 1
    Sheets(sheetName).range(Cells(hrow + 1, hCol), Cells(hrow + 1 + rowCnt, iCol)).CopyFromRecordset rs
    Sheets(sheetName).range(Cells(hrow, hCol), Cells(hrow, iCol)).Interior.ColorIndex = 17
    Sheets(sheetName).range(Cells(hrow, hCol), Cells(hrow + rowCnt, iCol)).Borders.LineStyle = xlContinuous
    rs.Close
    conn.Close
    CopyFromSQL = rowCnt
End Function

8.如果需要按了一个按钮后，填充另一个sheet的工作表，需要先用Activate语句，不然又报万能的“应用程序定义或者对象定义错误”！
PPSheet.Activate
CopyFromSQL strSQL, PPSheet, PPRange, irow, iCol

9.有一个奇怪的现象是执行过CopyFromRecordset后，填充到excel里面的数组字段显示成了日期格式
这个现象好像是忽然出现的，莫名其妙，数据库里返回的明明是数值字段，只不过前面一个字段是日期，后面的就变成了日期格式
目前还没找到解决办法。

10.数据库的字符串加了回车号，但显示回excel的时候并不会自动给换行，只好手动replace了

Sheets(PPSheet).Cells(irow, iCol) = Replace(value, Chr(13), vbCrLf)

11.VBA里面数组的类型为Variant,Function必须定义为这个类型才能返回

可以用Ubound(arr),LBound(arr)来得到最大和最小的下标，不能用length或者count

下面是一个十二宫位里画三方四正直线的代码

Public Sub ClearRange(ByVal sheetName As String, ByVal range As String)
    If Len(range) > 0 Then
        Sheets(sheetName).range(range).ClearContents
        Sheets(sheetName).range(range).Borders.LineStyle = xlNone
        Sheets(sheetName).range(range).Interior.Pattern = xlNone
    End If
End Sub
Public Sub ClearCellArray(ByVal sheetName As String, ByVal pos As Variant)
    For Each P In pos
      Sheets(sheetName).range(P).value = ""
    Next
End Sub
Public Sub ClearLine(ByVal sheetName As String)
    For Each x In Sheets(sheetName).Shapes
     If x.Type = msoLine Then
        x.Delete
     End If
     Next
End Sub
Public Sub DrawForGongWei(ByVal sheetName As String, ByVal zhipos As Integer, ByVal pos As Variant)
    Dim zmove As Integer, i As Integer, fromPos As String, toPos1 As String, toPos2 As String
    'zhiPos = zhiId Mod 12
    fromPos = pos(zhipos)
    'San Fang
    zmove = (zhipos + 12 + 4 * 1) Mod 12
    toPos1 = pos(zmove)
    DrawLine sheetName, fromPos, pos(zmove)
    zmove = (zhipos + 12 + 4 * 2) Mod 12
    toPos2 = pos(zmove)
    DrawLine sheetName, fromPos, pos(zmove)
    DrawLine sheetName, toPos1, toPos2
    'Dui Gong
    zmove = (zhipos + 18) Mod 12
    DrawLine sheetName, fromPos, pos(zmove)
End Sub

Public Function GetArrayPos(ByVal rangeStart As String, Optional offset As Integer = 2) As Variant
    Dim str2 As String, str3 As String, str4 As String, str5 As String, str6 As String, str7 As String, str8 As String, str9 As String, str10 As String, str11 As String, str12 As String
    Dim row As String, col As Integer
    row = Sheet1.range(rangeStart).row
    col = Sheet1.range(rangeStart).Column
    size = Sheet1.range(rangeStart).Rows.Count
    col = col - offset
    str2 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    col = col - offset
    str3 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    row = row - offset
    str4 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    row = row - offset
    str5 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    row = row - offset
    str6 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    col = col + offset
    str7 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    col = col + offset
    str8 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    col = col + offset
    str9 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    row = row + offset
    str10 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    row = row + offset
    str11 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    row = row + offset
    str12 = Sheet1.Cells(row, col).Address(0, 0) & ":" & Sheet1.Cells(row + size - 1, col + size - 1).Address(0, 0)
    
    
    GetArrayPos = Array(rangeStart, str2, str3, str4, str5, str6, str7, str8, str9, str10, str11, str12)
End Function
Public Function GetArrayPos2(ByVal rangeStart As String, ByVal colCnt As Integer) As Variant
    Dim pos() As Variant
    ReDim pos(colCnt)
  
    Dim row As Integer, col As Integer, i As Integer
    row = Sheet1.range(rangeStart).row
    col = Sheet1.range(rangeStart).Column
    rowOffset = Sheet1.range(rangeStart).Rows.Count
    For i = 0 To colCnt - 1 Step 1
     pos(i) = Sheet1.Cells(row, col + i).Address(0, 0) & ":" & Sheet1.Cells(row + rowOffset - 1, col + i).Address(0, 0)
    Next i

    GetArrayPos2 = pos
End Function
Public Sub DrawLine(ByVal sheetName As String, ByVal fromPos As String, ByVal toPos As String)
    Dim beginx As Integer, beginy As Integer, endx As Integer, endy As Integer
    beginx = GetRangeXY(fromPos, True)
    beginy = GetRangeXY(fromPos, False)
    endx = GetRangeXY(toPos, True)
    endy = GetRangeXY(toPos, False)
    Sheets(sheetName).Shapes.AddLine beginx, beginy, endx, endy
End Sub
Public Function GetRangeXY(ByVal pos As String, ByVal isX As Boolean) As Integer
   If isX Then
        Dim left As Integer, width As Integer
        left = range(pos).left
        width = range(pos).width
        GetRangeXY = left + width / 2
   Else
        Dim top As Integer, height As Integer
        top = range(pos).top
        height = range(pos).height
        GetRangeXY = top + height / 2
   End If
End Function

12.Open函数是必须放在ThisWorkbook里面才有效的，其它sheet里面不起作用

Private Sub Workbook_Open()
  MsgBox "test"
End Sub

13.可以在Sheet1里面call Sheet2的函数，只需要在函数名前面加Sheet2就可以了

14.获取日期
curYear = Year(Now)