Excel 项目定制、网页数据抓取、股票彩票表格、Excel培训
在进行QQ相关内容的网络数据采集时，经常看到需要附带bkn参数的时候。
如
|
1 |
https://qun.qq.com/cgi-bin/qunwelcome/myinfo?callback=?&bkn=114713469 |
经过分析QQ的网页JS，找到了bkn参数的获取算法如下：
|
1 2 3 4 5 6 |
e.getCSRFToken = function() { var t = e.cookie("skey"); if (t) { for (var r = 5381, n = 0, o = t.length; o > n; ++n) r += (r << 5) + t.charAt(n).charCodeAt(); return this.CSRFToken = 2147483647 & r } |
其中skey参数为登录QQ后的Cookie中附带的参数。
根据上述的Javascript算法，可以将其转换为如下的[……]
A股的交易日规定为凡是法定节假日和周末都不算交易日，其它日期都算交易日。
基于以上的知识，可以使用如下的代码获取2018年整年的沪深A股的所有交易日的日期：
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
Sub QQ1722187970() Dim dStart As Date Dim dEnd As Date dStart = VBA.DateSerial(Year(Now()), 1, 1) dEnd = VBA.DateSerial(Year(Now()), 12, 31) Dim arr() As Date dHoliday = Array(#1/1/2018#, #2/15/2018#, #2/16/2018#, #2/19/2018#, #2/20/2018#, #2/21/2018# _ , #4/5/2018#, #4/6/2018#, #4/30/2018#, #5/1/2018#, #6/18/2018#, #9/24/2018# _ , #10/1/2018#, #10/2/2018#, #10/3/2018#, #10/4/2018#, #10/5/2018#) For i = dStart To dEnd If UBound(VBA.Filter(dHoliday, i)) >= 0 Or Weekday(i, vbMonday) > 5 Then Else ReDim Preserve arr(k) arr(k) = i k = k + 1 End If Next i End Sub |
以上代码将把所有交易日期存储在arr数组中。
如果想要做成一个函数的，可以使用如下的代码：
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
Function GetAllDate() Dim dStart As Date Dim dEnd As Date dStart = VBA.DateSerial(Year(Now()), 1, 1) dEnd = VBA.DateSerial(Year(Now()), 12, 31) Dim oDicDate As Object Set oDicDate = CreateObject("Scripting.Dictionary") dHoliday = Array(#1/1/2018#, #2/15/2018#, #2/16/2018#, #2/19/2018#, #2/20/2018#, #2/21/2018# _ , #4/5/2018#, #4/6/2018#, #4/30/2018#, #5/1/2018#, #6/18/2018#, #9/24/2018# _ , #10/1/2018#, #10/2/2018#, #10/3/2018#, #10/4/2018#, #10/5/2018#) For i = dStart To dEnd If UBound(VBA.Filter(dHoliday, i)) >= 0 Or Weekday(i, vbMonday) > 5 Then Else oDicDate.Add i, k End If Next i GetAllDate = oDicDate.keys End Function |
[……]
将多个工作簿的内容合并到一个工作簿是一个经常会碰到的问题。
它的一般步骤是：
1.打开结果工作簿
2.遍历要合并的工作簿所在的文件夹
3.打开其中一个工作簿
4.将数据写入结果工作簿
5.关闭步骤3中打开的工作簿
6.重复步骤3-步骤5
7.调整结果工作簿的格式
8.弹出合并结束的消息
基于以上的步骤，可以使用如下的模板代码：
[cra[……]
将单元格区域的数据按照某个字段进行拆分，是一个经常需要遇到的问题。
以下代码利用字典按照任意字段拆分单元格区域的数据，同时将拆分后的数据单独另存为一个excel工作簿。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
Sub QQ1722187970() Dim oRng As Range Dim oRngHead As Range Set oRng = Application.InputBox("请选择要拆分的字段名", "拆分", , , , , , 8) Excel.Application.ScreenUpdating = False Excel.Application.DisplayAlerts = False Excel.Application.Calculation = xlCalculationManual If oRng.Columns.Count > 1 Then MsgBox "您未选择或者您选择的拆分字段有误,请重新选择" Else Dim oWK As Worksheet Dim oDic As Object Set oDic = CreateObject("scripting.dictionary") With oRng Set oWK = .Parent iRow = .CurrentRegion.Rows(1).Row iColField = .Column With oWK iRowEnd1 = .Cells(65536, iColField).End(xlUp).Row iColEnd = .Cells(iRow, 256).End(xlToLeft).Column iColStart = .Cells(iRow, iColField).End(xlToLeft).Column iRowEnd2 = .Cells(65536, iColStart).End(xlUp).Row Set oRngHead = .Cells(iRow, iColStart).Resize(1, iColEnd - iColStart + 1) For i = iRow + 1 To Excel.Application.WorksheetFunction.Max(iRowEnd1, iRowEnd2) Dim oRngTemp As Range Set oRngTemp = .Cells(i, iColStart).Resize(1, iColEnd - iColStart + 1) sText = .Cells(i, iColField).Value If Not oDic.Exists(sText) Then oDic.Add sText, oRngTemp Else Set oDic.Item(sText) = Excel.Application.Union(oDic.Item(sText), oRngTemp) End If Next i arrKeys = oDic.keys arrItems = oDic.items For i = 0 To UBound(arrItems) Dim oWB As Workbook Set oWB = Excel.Application.Workbooks.Add With oWB Dim oWK1 As Worksheet Set oWK1 = .Sheets(1) With oWK1 oRngHead.Copy .Range("a1") arrItems(i).Copy .Range("a2") .Columns.AutoFit End With .SaveAs Excel.ThisWorkbook.Path & "\" & arrKeys(i), xlOpenXMLWorkbook .Close End With Next i End With End With End If Excel.Application.Calculation = xlCalculationAutomatic Excel.Application.DisplayAlerts = True Excel.Application.ScreenUpdating = True End Sub |
在如何用vba打开选择文件和选择文件夹对话框？ 一文中我们介绍了使用vba内置的FileDialog对象用于操作打开文件和选择文件夹对话框。
当用 Application.FileDialog(msoFileDialogFilePicker) 弹出选择文件对话框时，默认会显示所有文件。
我们经常需要只显示某类文件，比如只显示excel 文件或者只显示word 文件。
这时候可以使[……]
在如何在vba中返回单元格Range对象的地址？一文中我们介绍了如何返回单元格的地址。
相反地，我们也会遇到需要把单元格地址转换为单元格Range对象。
vba中提供了Application对象的Evaluate方法可以直接把正确的单元格地址转换为单元格Range对象。
代码如下：
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
Sub QQ1722187970() Const xlA1 = 1 Const xlR1C1 = -4150 Dim oRng As Range Set oRng = Excel.ActiveSheet.Range("a1:b4") With oRng '获取单元格的地址 sAddress = .Address(False, False, , False) Dim oRng1 As Range '将单元格地址转换为单元格对象 Set oRng1 = Excel.Application.Evaluate(sAddress) End With End Sub |
当单元格地址是不含外部引用时[……]
Application.InputBox 方法可以弹出选择对话框，选择单元格区域。
但是如果在vba代码中设置了Excel.Application.ScreenUpdating = False 则会导致无法选择单元格区域。
如果要设置Excel.Application.ScreenUpdating = False，需要在Application.InputBox 语句之后设置。
以[……]
vba的内置函数或语句里没有求最大值的函数。
但是excel单元格函数中有max函数可以求最大值。
通过如何在vba中调用excel工作表函数？一文，我们可以通过在vba中调用excel工作表函数max来实现求最大值的目的。
代码如下：
|
1 2 3 |
Sub QQ1722187970() MsgBox Excel.Application.WorksheetFunction.Max(1, 100) End Sub |