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)
curYear = Year(Now)
