Excel 使用可变日期vba进行网页抓取

正在寻找从内部网络刮取/导入网页并粘贴到excel的解决方案

客观的 星期二至星期五-访问网页并导入当前和前一天的数据。周一需要导入当天和前3天（周日、周六和周五）的数据

我昨天录制了一个宏，它复制了包含网址的excel单元格，粘贴到“新web查询”中的“地址”字段，完成导入过程，并在前一天重复

这提供了预期的结果，但当我今天早上再次运行宏时，它返回了昨天和前一天的数据，因为网址是硬编码的

我将web地址的开头与日期元素连接起来，今天访问网页的地址位于单元格K2、前一天K3、-2天K4和-3天K5中

网页地址的常量部分启动http:/…prd03！后跟变量yyy！嗯!！dd

e、 g http:/…prd03！2018!07!今天12点 e、 g http:/…prd03！2018!07!昨天11点

明天http:/…prd03！2018!07!昨天是12点

下面是宏录制生成的代码 以

我已经打开了网页html源代码，今天的日期如下所示

A TITLE=“主页名”HREF=“/……！prd03！2018！07！12”>12

---

如果您能提供任何帮助，我们将不胜感激。如果需要更多信息，请告诉我。

在VBA中，您可以将URL编码为包含日期：

Dim fmtToday As String
Dim fmtYesterday As String
Dim fmtTwoDays As String
Dim fmtThreeDays As String
Dim BaseURL As String

BaseURL = "....prd03!" ' the first part of your url, change this to reflect your actual URL excluding http://

fmtToday = BaseURL & Format(Now, "yyyy!mm!dd") ' combine the BaseURL with the formated date
fmtYesterday = BaseURL & Format(Now - 1, "yyyy!mm!dd")  'combine the BaseURL with the formated date minus 1 day
fmtTwoDays = BaseURL & Format(Now - 2, "yyyy!mm!dd")  ' combine the BaseURL with the formated date minus 2 days
fmtThreeDays = BaseURL & Format(Now - 3, "yyyy!mm!dd")  ' combine the BaseURL with the formated date minus 3 days

然后，您可以在代码中引用它们：

Application.CutCopyMode = False

Range("K2").Value = "http://" & fmtToday

ActiveWorkbook.Worksheets.Add
ActiveSheet.Name = "Today"

With ActiveSheet.QueryTables.Add(Connection:= _
    "URL;http://" & fmtToday, _
    Destination:=Range("$A$1"))
    .Name = fmtToday
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlEntirePage
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With

---

我已经调整了您的代码以与fmtToday一起使用，要与前几天一起使用，您需要相应地调整您的代码。

Perfect。工作很愉快。谢谢。

Application.CutCopyMode = False

Range("K2").Value = "http://" & fmtToday

ActiveWorkbook.Worksheets.Add
ActiveSheet.Name = "Today"

With ActiveSheet.QueryTables.Add(Connection:= _
    "URL;http://" & fmtToday, _
    Destination:=Range("$A$1"))
    .Name = fmtToday
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlEntirePage
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With