Em có cái code chạy update kết quả nhờ các bác sửa cho phù hợp với Win 64bit và gán file excel chạy thử.
Code đây ạ:
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Dim rW As Long
Dim TP As clsMain
Sub Aut
pen()
Set TP = New clsMain
TP.Create Application
'Exit Sub
SpeedOnK
Call FixExcel
If PathExists("C:\Tamhoang") = False Then MkDir ("C:\Tamhoang")
Application.DisplayFormulaBar = False
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",false)"
Dim Index As Long, n As Long, Col As Long, row As Long, Text As String
Dim Rng As Range, fso As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Set Rng = Sheets("Lotto").Range("A2")
Ngay = Lotto.[a10000].End(3) + 1
If Hour(Now) > 18 Then
Dy = Date
Else
Dy = Date - 1
End If
For Days = Ngay To Dy
EndR = Lotto.[a10000].End(3).row
Sheet9.Range("B10").Resize(, 21).Value = Lotto.Range("BE10000").End(3).Resize(, 21).Value
URL = "http://www.minhngoc.net.vn/ket-qua-xo-so/mien-bac/"
URL = URL & Day(Days) & "-" & Month(Days) & "-" & Year(Days) & ".html"
DownloadFile_hn = URLDownloadToFile(0, URL, "C:\Tamhoang\vn.txt", 0, 0)
FilesToImport = "C:\Tamhoang\vn.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextSource = fs
penTextFile("C:\Tamhoang\vn.txt", 1, , -2)
NumOfLines = Split(TextSource.ReadAll, vbCrLf)
If UBound(NumOfLines) > 0 Then
Lotto.Cells(EndR + 1, "A") = Days
If Weekday(Days) = 1 Then
Lotto.Cells(EndR + 1, "B") = "CN"
Else
Lotto.Cells(EndR + 1, "B") = "T" & Weekday(Days)
End If
'ReDim Res(1 To UBound(NumOfLines), 1 To 1)
For row = 1 To UBound(NumOfLines)
Text = NumOfLines(row)
If Text <> "" Then
If InStr(Text, """giaidb""") > 0 Then
Lotto.Cells(EndR + 1, "C").Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
Sheet9.[L11].Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai1""") > 0 Then
Lotto.Cells(EndR + 1, "D") = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai2""") > 0 Then
Lotto.Cells(EndR + 1, "E") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "F") = "'" & Mid(NumOfLines(row + 1), 26, 5)
ElseIf InStr(Text, """giai3""") > 0 Then
Lotto.Cells(EndR + 1, "G") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "H") = "'" & Mid(NumOfLines(row + 1), 26, 5)
Lotto.Cells(EndR + 1, "I") = "'" & Mid(NumOfLines(row + 1), 42, 5)
Lotto.Cells(EndR + 1, "J") = "'" & Mid(NumOfLines(row + 1), 58, 5)
Lotto.Cells(EndR + 1, "K") = "'" & Mid(NumOfLines(row + 1), 74, 5)
Lotto.Cells(EndR + 1, "L") = "'" & Mid(NumOfLines(row + 1), 90, 5)
ElseIf InStr(Text, """giai4""") > 0 Then
Lotto.Cells(EndR + 1, "M") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "N") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "O") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "P") = "'" & Mid(NumOfLines(row + 1), 55, 4)
ElseIf InStr(Text, """giai5""") > 0 Then
Lotto.Cells(EndR + 1, "Q") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "R") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "S") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "T") = "'" & Mid(NumOfLines(row + 1), 55, 4)
Lotto.Cells(EndR + 1, "U") = "'" & Mid(NumOfLines(row + 1), 70, 4)
Lotto.Cells(EndR + 1, "V") = "'" & Mid(NumOfLines(row + 1), 85, 4)
ElseIf InStr(Text, """giai6""") > 0 Then
Lotto.Cells(EndR + 1, "W") = "'" & Mid(NumOfLines(row + 1), 10, 3)
Lotto.Cells(EndR + 1, "X") = "'" & Mid(NumOfLines(row + 1), 24, 3)
Lotto.Cells(EndR + 1, "Y") = "'" & Mid(NumOfLines(row + 1), 38, 3)
ElseIf InStr(Text, """giai7""") > 0 Then
Lotto.Cells(EndR + 1, "Z") = "'" & Mid(NumOfLines(row + 1), 10, 2)
Lotto.Cells(EndR + 1, "AA") = "'" & Mid(NumOfLines(row + 1), 23, 2)
Lotto.Cells(EndR + 1, "AB") = "'" & Mid(NumOfLines(row + 1), 36, 2)
Lotto.Cells(EndR + 1, "AC") = "'" & Mid(NumOfLines(row + 1), 49, 2)
Exit For
End If
End If
Next
End If
TextSource.Close
Lotto.Range("BE" & EndR + 1).Resize(, 9).Value = Sheet9.Range("B11").Resize(, 9).Value
DB.Range("A2").End(4).Offset(1).Resize(, 21).Value = Sheet9.Range("B11").Resize(, 21).Value
For Each Clls In Lotto.Range("C" & EndR + 1 & ":AC" & EndR + 1)
If Clls <> "" Then Clls.Offset(, 27) = "'" & Right(Clls, 2)
Next
Endrw = DB.[A2].End(4).row
DB.Range("K" & Endrw) = "'" & Sheet9.[L11]
DB.Range("M" & Endrw) = "'" & Right(DB.Range("K" & Endrw), 2)
DB.Range("R" & Endrw) = "'" & Bo(DB.Range("M" & Endrw))
If Lotto.Cells(EndR, "C") = "" Then
For rW = EndR To 2 Step -1
If Lotto.Cells(rW, "C") <> "" Then Exit For
Next
If Lotto.Cells(EndR + 1, "C") = Lotto.Cells(rW, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(rW, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
ElseIf Lotto.Cells(EndR + 1, "C") = Lotto.Cells(EndR, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(EndR, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If FileExists("C:\Tamhoang\vn.txt") = True Then objFSO.DeleteFile ("C:\Tamhoang\vn.txt"), DeleteReadOnly
'If PathExists("C:\Tamhoang") = True Then objFSO.deletefolder ("C:\Tamhoang"), DeleteReadOnly
With Application
.ScreenUpdating = False
.DisplayFormulaBar = False
.CommandBars("Formatting").Visible = False
.CommandBars("Standard").Visible = False
.StatusBar = False
.DisplayStatusBar = True
End With
With ActiveWindow
'.DisplayHeadings = False
.DisplayOutline = False
'.DisplayHorizontalScrollBar = True
'.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = False
.Zoom = 100
Application.ScreenUpdating = False
End With
Sheet3.Visible = 2
Sheet4.Visible = 2
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",False)"
Application.DisplayFormulaBar = False
Sheet1.Select
SpeedOff
End Sub
Sub Auto_Close()
Set TP = Nothing
With Application
.ScreenUpdating = True
.DisplayFormulaBar = True
.CommandBars("Formatting").Visible = True
.CommandBars("Standard").Visible = True
.StatusBar = True
.DisplayStatusBar = True
End With
With ActiveWindow
.DisplayHeadings = True
.DisplayOutline = True
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = True
.Zoom = 100
Application.ScreenUpdating = True
End With
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",True)"
Application.DisplayFormulaBar = True
Application.Calculation = xlCalculationAutomatic
Sheet1.Cells.Clear
Sheet1.[A:AA].ColumnWidth = 9
End Sub
Function PathExists(pname) As Boolean
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
End Function
Function FileExists(ByVal fname As String) As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
FileExists = fs.FileExists(fname)
End Function
Sub FixExcel()
With Application.ErrorCheckingOptions
.EvaluateToError = False
.TextDate = False
.NumberAsText = False
.InconsistentFormula = False
.OmittedCells = False
.UnlockedFormulaCells = False
'.ListLottoValidation = False
.InconsistentTableFormula = False
End With
End Sub
Xin chân thành cảm ơn các bác!
Code đây ạ:
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Dim rW As Long
Dim TP As clsMain
Sub Aut

Set TP = New clsMain
TP.Create Application
'Exit Sub
SpeedOnK
Call FixExcel
If PathExists("C:\Tamhoang") = False Then MkDir ("C:\Tamhoang")
Application.DisplayFormulaBar = False
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",false)"
Dim Index As Long, n As Long, Col As Long, row As Long, Text As String
Dim Rng As Range, fso As Object, FilesToImport
Dim TextSource As Object, NumOfLines, Cols, Res()
Set Rng = Sheets("Lotto").Range("A2")
Ngay = Lotto.[a10000].End(3) + 1
If Hour(Now) > 18 Then
Dy = Date
Else
Dy = Date - 1
End If
For Days = Ngay To Dy
EndR = Lotto.[a10000].End(3).row
Sheet9.Range("B10").Resize(, 21).Value = Lotto.Range("BE10000").End(3).Resize(, 21).Value
URL = "http://www.minhngoc.net.vn/ket-qua-xo-so/mien-bac/"
URL = URL & Day(Days) & "-" & Month(Days) & "-" & Year(Days) & ".html"
DownloadFile_hn = URLDownloadToFile(0, URL, "C:\Tamhoang\vn.txt", 0, 0)
FilesToImport = "C:\Tamhoang\vn.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextSource = fs

NumOfLines = Split(TextSource.ReadAll, vbCrLf)
If UBound(NumOfLines) > 0 Then
Lotto.Cells(EndR + 1, "A") = Days
If Weekday(Days) = 1 Then
Lotto.Cells(EndR + 1, "B") = "CN"
Else
Lotto.Cells(EndR + 1, "B") = "T" & Weekday(Days)
End If
'ReDim Res(1 To UBound(NumOfLines), 1 To 1)
For row = 1 To UBound(NumOfLines)
Text = NumOfLines(row)
If Text <> "" Then
If InStr(Text, """giaidb""") > 0 Then
Lotto.Cells(EndR + 1, "C").Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
Sheet9.[L11].Value = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai1""") > 0 Then
Lotto.Cells(EndR + 1, "D") = "'" & Mid(NumOfLines(row + 1), 10, 5)
ElseIf InStr(Text, """giai2""") > 0 Then
Lotto.Cells(EndR + 1, "E") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "F") = "'" & Mid(NumOfLines(row + 1), 26, 5)
ElseIf InStr(Text, """giai3""") > 0 Then
Lotto.Cells(EndR + 1, "G") = "'" & Mid(NumOfLines(row + 1), 10, 5)
Lotto.Cells(EndR + 1, "H") = "'" & Mid(NumOfLines(row + 1), 26, 5)
Lotto.Cells(EndR + 1, "I") = "'" & Mid(NumOfLines(row + 1), 42, 5)
Lotto.Cells(EndR + 1, "J") = "'" & Mid(NumOfLines(row + 1), 58, 5)
Lotto.Cells(EndR + 1, "K") = "'" & Mid(NumOfLines(row + 1), 74, 5)
Lotto.Cells(EndR + 1, "L") = "'" & Mid(NumOfLines(row + 1), 90, 5)
ElseIf InStr(Text, """giai4""") > 0 Then
Lotto.Cells(EndR + 1, "M") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "N") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "O") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "P") = "'" & Mid(NumOfLines(row + 1), 55, 4)
ElseIf InStr(Text, """giai5""") > 0 Then
Lotto.Cells(EndR + 1, "Q") = "'" & Mid(NumOfLines(row + 1), 10, 4)
Lotto.Cells(EndR + 1, "R") = "'" & Mid(NumOfLines(row + 1), 25, 4)
Lotto.Cells(EndR + 1, "S") = "'" & Mid(NumOfLines(row + 1), 40, 4)
Lotto.Cells(EndR + 1, "T") = "'" & Mid(NumOfLines(row + 1), 55, 4)
Lotto.Cells(EndR + 1, "U") = "'" & Mid(NumOfLines(row + 1), 70, 4)
Lotto.Cells(EndR + 1, "V") = "'" & Mid(NumOfLines(row + 1), 85, 4)
ElseIf InStr(Text, """giai6""") > 0 Then
Lotto.Cells(EndR + 1, "W") = "'" & Mid(NumOfLines(row + 1), 10, 3)
Lotto.Cells(EndR + 1, "X") = "'" & Mid(NumOfLines(row + 1), 24, 3)
Lotto.Cells(EndR + 1, "Y") = "'" & Mid(NumOfLines(row + 1), 38, 3)
ElseIf InStr(Text, """giai7""") > 0 Then
Lotto.Cells(EndR + 1, "Z") = "'" & Mid(NumOfLines(row + 1), 10, 2)
Lotto.Cells(EndR + 1, "AA") = "'" & Mid(NumOfLines(row + 1), 23, 2)
Lotto.Cells(EndR + 1, "AB") = "'" & Mid(NumOfLines(row + 1), 36, 2)
Lotto.Cells(EndR + 1, "AC") = "'" & Mid(NumOfLines(row + 1), 49, 2)
Exit For
End If
End If
Next
End If
TextSource.Close
Lotto.Range("BE" & EndR + 1).Resize(, 9).Value = Sheet9.Range("B11").Resize(, 9).Value
DB.Range("A2").End(4).Offset(1).Resize(, 21).Value = Sheet9.Range("B11").Resize(, 21).Value
For Each Clls In Lotto.Range("C" & EndR + 1 & ":AC" & EndR + 1)
If Clls <> "" Then Clls.Offset(, 27) = "'" & Right(Clls, 2)
Next
Endrw = DB.[A2].End(4).row
DB.Range("K" & Endrw) = "'" & Sheet9.[L11]
DB.Range("M" & Endrw) = "'" & Right(DB.Range("K" & Endrw), 2)
DB.Range("R" & Endrw) = "'" & Bo(DB.Range("M" & Endrw))
If Lotto.Cells(EndR, "C") = "" Then
For rW = EndR To 2 Step -1
If Lotto.Cells(rW, "C") <> "" Then Exit For
Next
If Lotto.Cells(EndR + 1, "C") = Lotto.Cells(rW, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(rW, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
ElseIf Lotto.Cells(EndR + 1, "C") = Lotto.Cells(EndR, "C") And Lotto.Cells(EndR + 1, "D") = Lotto.Cells(EndR, "D") Then
Lotto.Range("C" & EndR + 1).Resize(, 54).ClearContents
Lotto.Cells(EndR + 1, "M").Resize(, 10).ClearContents
Lotto.Cells(EndR + 1, "K") = "TET"
End If
Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If FileExists("C:\Tamhoang\vn.txt") = True Then objFSO.DeleteFile ("C:\Tamhoang\vn.txt"), DeleteReadOnly
'If PathExists("C:\Tamhoang") = True Then objFSO.deletefolder ("C:\Tamhoang"), DeleteReadOnly
With Application
.ScreenUpdating = False
.DisplayFormulaBar = False
.CommandBars("Formatting").Visible = False
.CommandBars("Standard").Visible = False
.StatusBar = False
.DisplayStatusBar = True
End With
With ActiveWindow
'.DisplayHeadings = False
.DisplayOutline = False
'.DisplayHorizontalScrollBar = True
'.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = False
.Zoom = 100
Application.ScreenUpdating = False
End With
Sheet3.Visible = 2
Sheet4.Visible = 2
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",False)"
Application.DisplayFormulaBar = False
Sheet1.Select
SpeedOff
End Sub
Sub Auto_Close()
Set TP = Nothing
With Application
.ScreenUpdating = True
.DisplayFormulaBar = True
.CommandBars("Formatting").Visible = True
.CommandBars("Standard").Visible = True
.StatusBar = True
.DisplayStatusBar = True
End With
With ActiveWindow
.DisplayHeadings = True
.DisplayOutline = True
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = True
.Zoom = 100
Application.ScreenUpdating = True
End With
Application.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"",True)"
Application.DisplayFormulaBar = True
Application.Calculation = xlCalculationAutomatic
Sheet1.Cells.Clear
Sheet1.[A:AA].ColumnWidth = 9
End Sub
Function PathExists(pname) As Boolean
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
End Function
Function FileExists(ByVal fname As String) As Boolean
Set fs = CreateObject("Scripting.FileSystemObject")
FileExists = fs.FileExists(fname)
End Function
Sub FixExcel()
With Application.ErrorCheckingOptions
.EvaluateToError = False
.TextDate = False
.NumberAsText = False
.InconsistentFormula = False
.OmittedCells = False
.UnlockedFormulaCells = False
'.ListLottoValidation = False
.InconsistentTableFormula = False
End With
End Sub
Xin chân thành cảm ơn các bác!