Манипулирование файлами .htm в Excel vba

Question

Я пытаюсь сделать приложение в Excel vba, но у меня есть некоторые проблемы. Мне нужно приложение Excel для загрузки некоторых файлов, находящихся в формате zip. Я уже сделал эту часть проблемы, мое приложение может загружать и распаковывать файлы. Затем я должен прочитать весь файл в расширении .htm и получить от него некоторую информацию. Требуется работать так, чтобы при открытии приложения программа должна искать последний номер конкурса, который является «concurso» в Basil, затем ищет тот же номер в файле .htm и начинает копировать следующие данные.

Я уже открыл шаблон для чтения файла и получения данных, которые я хочу, но я не знаю, как его кодировать. Шаблон в файле .htm, который нужно извлечь, находится внутри тегов td, текст, который имеет 2 косой черты, поэтому у меня есть дата, в настоящее время я должен сделать 3 вещи, получить дату, линию над датой У меня число concurso, поэтому мне нужно его тоже получить, а 15 строк под датой у меня 15 номеров, в которых они мне тоже нужны. Этот шаблон не изменяется и должен обрабатываться до конца файла .htm. и переносить эти данные на мой лист, который будет обрабатываться позже.

В случае возникновения каких-либо сомнений относительно проблемы я предоставлю дополнительные разъяснения.
Это код, который я использую, чтобы загрузить и распаковать файлы. ↓

Sub DownloadEUnzip() 
    Dim FSO, oApp As Object 
    Dim objHttp, DefPath, Arquivo As String 
    Dim Dados() As Byte 
    Dim Fname As Variant 
    Dim FileNameFolder As Variant 
    Dim iFileNumber As Long 

    Dim diretorio As String 

    diretorio = Dir("c:\lotofacil\D_LOTFAC.HTM") 

    If diretorio = "D_LOTFAC.HTM" Then 
     Kill "C:\lotofacil\*" 
    End If 

    Set objHttp = CreateObject("MSXML2.ServerXMLHTTP") 
    objHttp.Open "GET", "http://www1.caixa.gov.br/loterias/_arquivos/loterias/D_lotfac.zip", False 
    objHttp.Send 
    DefPath = "C:\lotofacil\" '<<< Altere aqui 
    Arquivo = DefPath & "D_lotfac.zip" 
    If objHttp.Status = "200" Then 
     Dados = objHttp.ResponseBody 
     iFileNumber = FreeFile 
     Open Arquivo For Binary Access Write As #iFileNumber 
     Put #iFileNumber, 1, Dados 
     Close #iFileNumber 
    End If 
    If Right(DefPath, 1) <> "\" Then 
     DefPath = DefPath & "\" 
    End If 
    FileNameFolder = DefPath 

    Set oApp = CreateObject("Shell.Application") 
    oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace("C:\lotofacil\D_lotfac.zip").items 
    MsgBox "Arquivos baixados e descompactados com sucesso!" 
End Sub 

HERE можно загрузить файл для визуализации проблемы.

ps Папка под названием lotofacil должна быть создана на диске C: для нормальной работы таблицы.

UPDATE 1

код, чтобы найти дату

If Mid(dataline, 19, 1) = "/" And Mid(dataline, 22, 1) = "/" Then 
    Debug.Print dataline 
End If 

UPDATE 2

так Кайо, его очень быстро сейчас, но в то время как i'm использованием я заметил, что программа принимала столбец меньше, чем необходимость, и я меняю код, и он работает. По-видимому ... хотелось бы взглянуть, не вижу ли я беспорядка ... Я меняю s ize массива, и выглядят так, как будто это работает :) Взгляните.

Sub ReadLines() 

Dim dataArray() As String 
Dim strText 
Dim result As String 
Dim regExDate As New RegExp, regExAnyContent As New RegExp 
Dim matches As MatchCollection 
Dim match As match 
Dim previous As String, current As String 
Dim currentLine As Integer 
ReDim dataArray(17, 1000) 

regExDate.Pattern = "(\d{2}/\d{2}/\d{4})" 
regExAnyContent.Pattern = "<td[^>]*>([^<]*)" 
dirPath = "c:\lotofacil\" 
filePath = dirPath & "D_LOTFAC.HTM" 
result = "" 
currentLine = 0 

If Not Dir(filePath) = "D_LOTFAC.HTM" Then Exit Sub 
FileNum = FreeFile() 

Open filePath For Input As #FileNum 
previous = "" 

While Not EOF(FileNum) 
    Line Input #FileNum, current ' read in data 1 line at a time 

    If Len(current) > 0 Then 
     Set matches = regExDate.Execute(current) 
     If matches.Count > 0 Then 
      dataArray(1, currentLine) = matches.Item(0) 
      dataArray(0, currentLine) = regExAnyContent.Execute(previous).Item(0).SubMatches(0) 
      For i = 1 To 16 
       Line Input #FileNum, current 
       While current = "" 
        Line Input #FileNum, current 
       Wend 
       dataArray(1 + i, currentLine) = regExAnyContent.Execute(current).Item(0).SubMatches(0) 
      Next 
      currentLine = currentLine + 1 
      If currentLine Mod 1000 = 0 Then 
       ReDim Preserve dataArray(17, currentLine + 1000) 
      End If 
     End If 
     previous = current 
    End If 


    ' decide what to do with dataline, 
    ' depending on what processing you need to do for each case 
Wend 

Range(Cells(1, 1), Cells(currentLine, 17)) = Application.Transpose(dataArray) 

End Sub 

, но до сих пор Happenin вещь действительно странно, в листе, который гнал данные, даты неверны, я нуждался в них в формате дд/мм/гггг, и я знаю, что я уже пристанет U , но если слишком сложно сделать это изменение, вы можете просто снять этот столбец даты? пожалуйста ...

и прежде всего большое спасибо, u're очень хорошо на первенствует;)

Answer 1

Попробуйте прочитать файл в буфер обмена и вставить его содержимое в рабочий лист, это создаст обычную таблицу Excel, с которой вы сможете работать.

Это будет использовать естественную способность excel анализировать таблицу html для регулярной таблицы excel.

 
Sub ReadFilePasteAsTable() 
Dim objData As New MSForms.DataObject 
Dim strText 
Dim result As String 
Dim numberOfLines Integer 
Dim wsh As Object 
Set wsh = VBA.CreateObject("WScript.Shell") 


numberOfLines = 126 
dirPath = "c:\lotofacil\" 
diretorio = Dir(dirPath & "D_LOTFAC.HTM") 
result = "" 

If Not diretorio = "D_LOTFAC.HTM" Then Exit Sub 
FileNum = FreeFile() 

filePath = dirPath & "D_LOTFAC.HTM" 
outPath = dirPath & "out.txt" 
pscommand = "Powershell -Command ""''+$(cat " & filePath & " -Tail 126) > " & outPath & """" 
wsh.Run pscommand, 0, True 

Open outPath For Input As #FileNum 

While Not EOF(FileNum) 
    Line Input #FileNum, DataLine ' read in data 1 line at a time 
    result = result & DataLine 
    ' decide what to do with dataline, 
    ' depending on what processing you need to do for each case 
Wend 

    objData.SetText result 
    objData.PutInClipboard 

ActiveSheet.Paste Destination:=[A1] 
End Sub 

Не забудьте добавить ссылку на Microsoft Forms 2.0. Чтобы добавить ссылку открыть окно VBA, откройте меню Tools-> Литература ...

Если вы не можете найти Microsoft Forms 2.0 Библиотека объектов открыть Обзор ... и он будет находиться в папке C: \ Windows \ SysWOW64 \ FM20.dll для 64-разрядной ОС или C: \ Windows \ System32 \ FM20.dll для 32 бит.

UPDATE

Теперь вам нужно добавить ссылку на Microsoft VBScript Regular Expressions 5.5

Sub ReadLines() 
Dim dataArray() As String 
Dim strText 
Dim result As String 
Dim regExDate As New RegExp, regExAnyContent As New RegExp 
Dim matches As MatchCollection 
Dim match As match 
Dim previous As String, current As String 
Dim currentLine As Integer 
ReDim dataArray(16, 1000) 

regExDate.Pattern = "(\d{2}/\d{2}/\d{4})" 
regExAnyContent.Pattern = "<td[^>]*>([^<]*)" 
dirPath = "c:\lotofacil\" 
filePath = dirPath & "D_LOTFAC.HTM" 
result = "" 
currentLine = 0 

If Not Dir(filePath) = "D_LOTFAC.HTM" Then Exit Sub 
FileNum = FreeFile() 

Open filePath For Input As #FileNum 
previous = "" 

While Not EOF(FileNum) 
    Line Input #FileNum, current ' read in data 1 line at a time 

    If Len(current) > 0 Then 
     Set matches = regExDate.Execute(current) 
     If matches.Count > 0 Then 
      dataArray(1, currentLine) = matches.Item(0) 
      dataArray(0, currentLine) = regExAnyContent.Execute(previous).Item(0).SubMatches(0) 
      For i = 1 To 15 
       Line Input #FileNum, current 
       While current = "" 
        Line Input #FileNum, current 
       Wend 
       dataArray(1 + i, currentLine) = regExAnyContent.Execute(current).Item(0).SubMatches(0) 
      Next 
      currentLine = currentLine + 1 
      If currentLine Mod 1000 = 0 Then 
       ReDim Preserve dataArray(16, currentLine + 1000) 
      End If 
     End If 
     previous = current 
    End If 


    ' decide what to do with dataline, 
    ' depending on what processing you need to do for each case 
Wend 



Range(Cells(1, 1), Cells(currentLine, 16)) = Application.Transpose(dataArray) 
End Sub