Excel VBA - 读书上网笔记

20，UTF-8文件 by:winland

‘http://club.excelhome.net/thread-513237-1-1.html

Public Declare Function WideCharToMultiByte Lib \ ByVal CodePage As Long, _ ByVal dwFlags As Long, _

ByVal lpWideCharStr As Long, _ ByVal cchWideChar As Long, _ ByRef lpMultiByteStr As Any, _ ByVal cchMultiByte As Long, _ ByVal lpDefaultChar As String, _

ByVal lpUsedDefaultChar As Long) As Long

ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long Public Const CP_UTF8 = 65001

Private Sub WriteOut(strPath As String, str As String) Dim lBufSize As Long Dim lRest As Long Dim bUTF8() As Byte Dim TLen As Long

TLen = Len(str)

lBufSize = TLen * 3 + 1 ReDim bUTF8(lBufSize - 1)

lRest = WideCharToMultiByte(CP_UTF8, 0, StrPtr(str), TLen, bUTF8(0), lBufSize, vbNullString, 0)

If lRest Then

lRest = lRest - 1

ReDim Preserve bUTF8(lRest) Open strPath For Binary As #1 Put #1, , bUTF8 Close #1 End If End Sub

21，Match函数用在字典上

k = d.keys t = d.items

ReDim brr(1 To d.Count, 1 To 3) With WorksheetFunction For i = 1 To d.Count brr(i, 1) = i

brr(i, 3) = .Large(t, i)

m = .Match(brr(i, 3), t, 0) - 1 brr(i, 2) = k(m) Next End With

m = Application.Match(xx, t, 0) – 1 如果找不到会出错。

22，单元格区域保护

‘2012-2-25

With Sheets(\费用明细\

.Cells.Locked = False ‘取消锁定 .Range(\‘锁定

.EnableSelection = xlUnlockedCells ‘其它区域不能选择 .Protect (\End With

23，数据类型

数据类型 Integer % Long & Single ! Double # String $ Currency @

24，自动筛选时标题变化

‘http://club.excelhome.net/thread-831374-1-1.html Sub Macro1() With Sheet1

If .AutoFilterMode Then

With .AutoFilter.Filters(1) If .On Then

[g1] = Mid(.Criteria1, 2) & \完成量统计表\ Else

[g1] = \完成量统计表\

End If End With End If End With End Sub

25，多工作簿导入 by:狼版主

‘http://club.excelhome.net/thread-830688-1-1.html Sub 导入数据()

Dim f As String, SrcBook As Workbook, sh As Worksheet, arr, n As Long

f = Dir(ThisWorkbook.Path & \ Application.ScreenUpdating = False Set sh = ActiveWorkbook.ActiveSheet While f > \

Set SrcBook = Workbooks.Open(ThisWorkbook.Path & \ n = SrcBook.Sheets(1).UsedRange.Rows.Count - 3 arr = SrcBook.Sheets(1).[b4].Resize(n, 17)

sh.[A65536].End(3).Offset(1, 0).Resize(n, 17) = arr SrcBook.Close False f = Dir Wend

Application.ScreenUpdating = True MsgBox \End Sub

26，指定段日期中有几个星期三

‘2012-2-27

Function jgxq3(qs, zz, x)

'星期一 x=1；星期二 x=2；星期日 x=7 'qs 起始日期 'zz 终止日期 Dim n%

n = DateDiff(\xq1 = Weekday(qs) If xq1 < x + 1 Then n = n - x - 1 + xq1 jgxq3 = Int(n / 7) + 1 ElseIf xq1 = x + 1 Then

jgxq3 = Int(n / 7) + 1 Else

n = n - x - 1 + xq1 jgxq3 = Int(n / 7) End If

End Function 用法： Sub yy()

qs = #2/26/2012# zz = #3/25/2012#

MsgBox qs & \～\有 \星期三。\

End Sub

本周一的日期：

aa = Date - Weekday(Date, 2) + 1

今日所在周的周数：

aa = Format(Date ,”ww”)

‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1115630&page=3#pid7600864

‘某月中的星期日的日期和应出勤天数 Sub rq()

Dim r, bt$, dd, qs, i&, xq, zr$, n&, z$ r = Sheet1.[d2].Value

bt = Year(r) & \年\月份指纹原始记录\dd = Day(DateSerial(Year(r), Month(r) + 1, 0)) qs = DateSerial(Year(r), Month(r), 1) For i = qs To qs + dd - 1 xq = Weekday(i) If xq = 1 Then

zr = zr & Day(i) & \ End If Next

zr = Left(zr, Len(zr) - 1)

z = \注：本月星期天分别为 \日。本月应出勤天数为\& \天。\

End Sub