卡塔尔世界杯排名_98世界杯决赛 - dylfjc.com

VBA学习笔记七：自定义函数

要求：第一列生成指定日期范围的所有日期，第二列判断每个日期是否为工作日或节假日，然后让用户选择要写入的位置，最后将内容写入到指定的单元格区域中代码： Sub GenerateDatesAndCheckWorkdays()

Dim startDate As Date, endDate As Date

Dim currentDate As Date

Dim dateRange() As Variant

Dim i As Long

Dim ws As Worksheet

Dim targetRange As Range

' 指定日期范围

startDate = "2024-08-01"

endDate = "2024-08-10"

' 初始化日期数组

ReDim dateRange(1 To (endDate - startDate + 1), 1 To 2)

' 循环生成日期，并判断是否为工作日或节假日

currentDate = startDate

For i = 1 To UBound(dateRange)

dateRange(i, 1) = currentDate

' 调用`CheckWorkDay`函数，检查某个日期是否为工作日

dateRange(i, 2) = CheckWorkDay(currentDate)

currentDate = currentDate + 1

Next i

' 让用户选择指定单元格的左上角位置作为数据写入区域

On Error Resume Next

Set targetRange = Application.InputBox("请选择目标单元格的左上角位置", Type:=8)

On Error GoTo 0

If targetRange Is Nothing Then

MsgBox "操作已取消", vbExclamation

Exit Sub

End If

' 将数组内容写入指定区域

Set targetRange = targetRange.Resize(UBound(dateRange, 1), UBound(dateRange, 2))

targetRange.Value = dateRange

MsgBox "日期和工作日状态已成功写入", vbInformation

End Sub

Function CheckWorkDay(dateValue As Date) As String

Dim response As String

' 调用 `GetWebData` 函数发送HTTP请求，返回服务器响应的内容

response = GetWebData("http://tool.bitefu.net/jiari/?d=" & Format(dateValue, "yyyymmdd"))

' 判断返回的结果是否为0

If response = "0" Then

CheckWorkDay = "工作日"

Else

CheckWorkDay = "节假日"

End If

End Function

Function GetWebData(url As String) As String

' 声明XMLHTTP对象用于发送HTTP请求

Dim httpRequest As Object

Set httpRequest = CreateObject("MSXML2.XMLHTTP.6.0")

' 初始化HTTP请求

httpRequest.Open "GET", url, False

' 发送请求

httpRequest.send

' 将服务器响应的内容返回

GetWebData = httpRequest.responseText

End Function

代码解释：

`GenerateDatesAndCheckWorkdays` 子过程：生成指定日期范围的所有日期，并判断每个日期是否为工作日或节假日

`CheckWorkDay` 函数：通过调用 `GetWebData` 函数发送HTTP请求，检查某个日期是否为工作日，如果返回值为 `"0"`，表示是工作日；否则为节假日

`GetWebData` 函数：发送HTTP GET请求，获取服务器返回的数据，返回服务器响应的内容

特别说明：

函数中使用了 VBA 的 `XMLHTTP` 对象与服务器进行通信，以获取指定URL的响应数据，关于此对象的说明可以参考这个博主写的https://www.cnblogs.com/caidongji/p/16905519.htmlhttps://www.cnblogs.com/caidongji/p/16905519.html