|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
各位大虾求助,目前有100份左右的网页需要批量导入数据,导入的字段共有50列,其中有几列的字段内容以15位以上的数字,希望能得到各位大虾的相助,谢谢。
Sub main()
Dim url As String, mypath As String, fn As String
Rows("2:65536").Clear
mypath = ThisWorkbook.Path & "\"
fn = Dir(mypath & "*.ht*")
Do While fn <> ""
url = "file:///" & Replace(mypath & fn, "\", "/")
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Split(fn, ".")(0)
提取数据 url, ActiveSheet
fn = Dir()
Loop
If Sheets.Count > 1 Then
For i = 2 To Sheets.Count
Sheets(i).Activate
Range("a1", Range("a65536").End(xlUp)).EntireRow.Copy Sheets(1).[a65536].End(xlUp).Offset(1, 0)
Application.CutCopyMode = False
Next
End If
Sheets("汇总").Activate
[a1].Select
End Sub
Sub 提取数据(url As String, sht As Worksheet)
Dim QT As QueryTable
Set QT = sht.QueryTables.Add(Connection:="Url;" & url, Destination:=sht.Range("a1"))
With QT
.WebFormatting = xlWebFormattingAll
.WebTables = "1"
.WebSelectionType = xlSpecifiedTables
.TextFileStartRow = 1
.TextFileConsecutiveDelimiter = True
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = True
' .TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2)
.Refresh
.Delete
End With
End Sub
|
|