Làm sao để trích lọc giá trị từ Text file đưa vào file Excel

Liên hệ QC
P

phanminhphuong

Thành viên hoạt động
Tham gia
26/7/13
Bài viết
127
Được thích
68
Chào các bạn
Mình có file "source web fso.txt" có nội dung rất dài - trích dẫn cấu trúc
PHP: 
name=ctl00$ctl27$wPshipList$ctl00$ddlShip jQuery16106108220824075696="3"> <OPTION 

value=d66e1b9f-902a-4c53-a7fe-022813ab1c24>ACE STAR</OPTION> <OPTION value=88b4de2b-0601-46c4-8453-cb80bb223f90>ACX MARGUERITE</OPTION> 

<OPTION value=98a88e81-b7e0-4b71-bbff-23424b1da1cf>ADVANTAGE</OPTION> <OPTION value=c76e1aa1-8d0d-42b7-83ee-7087b7e59c5e>AFRICAN 

VENTURE</OPTION> <OPTION selected value=1834ddbc-9324-4c47-b3fc-8334f08047f0>AIR NESS</OPTION> <OPTION value=1fa7c60f-e0c3-4ea8-b53c-

6bed2a5f1169>AK PHOENICIA</OPTION> <OPTION value=82aea3c0-2102-45e2-947a-3c71a214bfd7>AKIJ GLORY</OPTION> <OPTION value=e2795696-a896-4d7b-

9ad9-7a7ad6376122>ALABAMA BELLE</OPTION> <OPTION value=f9c666c5-4f26-4fdd-bb44-82e31e1fa977>ALABAMA BELLE</OPTION> <OPTION value=11a86129-

a566-46e8-b182-0a89470f04b7>ALABAMA BELLE</OPTION> <OPTION value=e648cbc5-8378-4e84-9bc0-f000c6073416>ALABAMA BELLE</OPTION> <OPTION 

value=9c396969-9bbb-493e-8df4-ff4f881650fd>ALABAMA BELLE</OPTION> <OPTION value=1973bbba-8c6d-431d-83d2-19afcbecdc98>ALEXANDROS THEO</OPTION> 

<OPTION value=238e3682-c314-4f90-a6c1-b79d7a58afaa>ALICE</OPTION> <OPTION value=1a36e6cd-55c3-4ab3-98c1-8a370ff26ed7>ALPHA JUPITER</OPTION> 

<OPTION value=6ed62bcc-9182-4c74-96b8-ff47db0d70f8>ALPINE ATHELIA</OPTION> <OPTION value=593f27c3-18d3-4cee-80ef-8649634819e8>AMA</OPTION> 

<OPTION value=5125976a-9656-4c4a-9fc2-a791ff521c71>AMAGI</OPTION> <OPTION value=de751c71-8a0a-41e3-a19f-20a6e59676a6>AMS PEGASUS I</OPTION> 

<OPTION value=a2ad346d-1a46-4596-9e92-a3e053742627>AMSIR</OPTION> <OPTION value=ff45a029-8911-4933-8ebf-143902bf9f4f>AN QUAN ZHOU 66</OPTION> 

<OPTION value=96a0000e-6ff5-4b2f-861c-dd2c8b7011f5>AN QUAN ZHOU 66
Các bạn xem thêm trong file đính kèm

* Yêu cầu viết code VBA cho file "Test.xls" (cùng thư mục với file "source web fso.txt") để trích lọc giá trị từ Textfile này đưa vào file Text.xls
- Ví dụ cụ thể:
+ Trong file Text.xls nếu giá trị Sheet1.Cells(2,2) = "ACE STAR" thì Sheet1.Cells(2,3) = "d66e1b9f-902a-4c53-a7fe-022813ab1c24"
+ Tức là lấy giá trị đoạn value (sau dấu = và trước dấu >) trước từ "ACE STAR" (value=d66e1b9f-902a-4c53-a7fe-022813ab1c24>ACE STAR). Chuỗi màu đỏ này bao giờ cũng liền mạch
+ Nếu không có VD Cells(2,2) = "ACE STAR 1" thì Cells(2,3) = ""
 

File đính kèm

  • Test.xls
    28 KB · Đọc: 11
  • source web fso.txt
    9.4 KB · Đọc: 6
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
phanminhphuong đã viết:
Chào các bạn
Mình có file "source web fso.txt" có nội dung rất dài - trích dẫn cấu trúc
......................
......................
Các bạn xem thêm trong file đính kèm

* Yêu cầu viết code VBA cho file "Test.xls" (cùng thư mục với file "source web fso.txt") để trích lọc giá trị từ Textfile này đưa vào file Text.xls
- Ví dụ cụ thể:
+ Trong file Text.xls nếu giá trị Sheet1.Cells(2,2) = "ACE STAR" thì Sheet1.Cells(2,3) = "d66e1b9f-902a-4c53-a7fe-022813ab1c24"
+ Tức là lấy giá trị đoạn value (sau dấu = và trước dấu >) trước từ "ACE STAR" (value=d66e1b9f-902a-4c53-a7fe-022813ab1c24>ACE STAR). Chuỗi màu đỏ này bao giờ cũng liền mạch
+ Nếu không có VD Cells(2,2) = "ACE STAR 1" thì Cells(2,3) = ""
Nhấp chuột vào đây để mở rộng...

Cho nguyên đống code này vào 1 Module:
Mã: 
Public Dic As Object
Private Sub GetValFromTxt(ByVal txtFile As String)
  Dim aTmp, aVals, arr(), tmp As String
  Dim lPos1 As Long, lPos2 As Long, n As Long
  On Error Resume Next
  If InStr(txtFile, "\") = 0 Then txtFile = ThisWorkbook.Path & "\" & txtFile
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(txtFile) Then
      With .OpenTextFile(txtFile, 1, , -2)
        tmp = Trim(.ReadAll)
        .Close
      End With
      tmp = Replace(tmp, vbCrLf, " ", , , vbTextCompare)
      If Len(tmp) Then
        lPos1 = InStr(1, tmp, "<OPTION value=", vbTextCompare) + 14
        tmp = Mid(tmp, lPos1)
        lPos2 = InStrRev(tmp, "</OPTION>", , vbTextCompare) - 1
        tmp = Left(tmp, lPos2)
        tmp = Replace(tmp, "<OPTION value=", "", , , vbTextCompare)
        tmp = Replace(tmp, "<OPTION selected value=", "", , , vbTextCompare)
        aTmp = Split(tmp, "</OPTION>", , vbTextCompare)
        ReDim arr(1 To UBound(aTmp) + 1, 1 To 2)
        Dim strKey As String, strItem As String
        For n = 0 To UBound(aTmp)
          aVals = Split(aTmp(n), ">")
          strKey = CStr(Trim(aVals(1)))
          strItem = CStr(Trim(aVals(0)))
          Dic.Add strKey, strItem
        Next
      End If
    End If
  End With
End Sub
Function VlookupTxt(ByVal Lookup_Value, ByVal txtFile As String) As String
  Dim arr, Item, tmp
  On Error Resume Next
  Application.Volatile
  VlookupTxt = vbNullString
  If InStr(txtFile, "\") = 0 Then txtFile = ThisWorkbook.Path & "\" & txtFile
  If CreateObject("Scripting.FileSystemObject").FileExists(txtFile) Then
    If Dic Is Nothing Then
      Set Dic = CreateObject("Scripting.Dictionary")
      GetValFromTxt txtFile
    End If
    If Dic.Count Then
      Lookup_Value = CStr(Lookup_Value)
      If Dic.Exists(Lookup_Value) Then
      VlookupTxt = Dic.Item(Lookup_Value)
      End If
    End If
  End If
End Function
Tại cell B2, gõ công thức:
Mã: 
=VlookupTxt(A2,"[COLOR=#ff0000]source web fso.txt[/COLOR]")
Lưu ý:
- Chổ màu đỏ là đường dẫn đến file txt
- Nếu chỉ ghi tên file (không ghi đường dẫn đầy đủ) thì đồng nghĩa là file txt ấy nằm cùng thư mục với file Excel
 

File đính kèm

  • VLOOKUP_TXT.rar
    16.9 KB · Đọc: 37
Upvote 0
ndu96081631 đã viết:
Tại cell B2, gõ công thức:
Mã: 
=VlookupTxt(A2,"[COLOR=#ff0000]source web fso.txt[/COLOR]")
Lưu ý:
- Chổ màu đỏ là đường dẫn đến file txt
- Nếu chỉ ghi tên file (không ghi đường dẫn đầy đủ) thì đồng nghĩa là file txt ấy nằm cùng thư mục với file Excel
Nhấp chuột vào đây để mở rộng...
Rất cảm ơn bạn!

Cho mình hỏi thêm 1 ý nữa:
1) Bây giờ mình lấy được Source code của trang Web bằng code VBA và gán vào biến sText (tức là sText có value như là file "source web fso.txt") vậy phải dùng code như thế nào để xử lí biến sText đó được kết quả tương đương (Sheet1.[B2] = sText là OK). Tại mình đang học về mảng nên chưa vận dụng được nhiều
2) Nếu biến sText là biến String thì có giới hạn gì hay lỗi gì phát ssinh nếu Source của Web page quá nhiều?

Mong các bạn giúp đỡ
 
Lần chỉnh sửa cuối:
Upvote 0
phanminhphuong đã viết:
Rất cảm ơn bạn!

Cho mình hỏi thêm 1 ý nữa:
1) Bây giờ mình lấy được Source code của trang Web bằng code VBA và gán vào biến sText (tức là sText có value như là file "source web fso.txt") vậy phải dùng code như thế nào để xử lí biến sText đó được kết quả tương đương (Sheet1.[B2] = sText là OK). Tại mình đang học về mảng nên chưa vận dụng được nhiều
2) Nếu biến sText là biến String thì có giới hạn gì hay lỗi gì phát ssinh nếu Source của Web page quá nhiều?

Mong các bạn giúp đỡ
Nhấp chuột vào đây để mở rộng...

Chưa hiểu lắm. Bạn cho file lên cho dễ
 
Upvote 0
ndu96081631 đã viết:
Chưa hiểu lắm. Bạn cho file lên cho dễ
Nhấp chuột vào đây để mở rộng...
Bạn xem giúp mình
Đã ghi yêu cầu trong file
Mã: 
VD mình lấy được Source của Website có nội dung như ô B2     (sText = Sheet1.[B2])
(tất nhiên Cell ko thể chứa được quá nhiều String)
[B][COLOR=#ff0000]
Dim sText as String
[/COLOR][/B][B][COLOR=#ff0000]sText = oInternetExplorer.Document.Body.innerHTML
[/COLOR][/B]Câu hỏi 1) xử lý biến sText như thế nào để cho kết quả ở ô E4 nếu có tương ứng Text ở D4
2) Nếu Text ở D4 ko có trong sText thì tất nhiên E4 = ""
3) Có vấn đề gì với code màu đỏ ở trên nếu Source web quá dài không ?
Mình muốn ứng dụng đoạn này mà chưa hiểu lắm
PHP: 
sText = Replace(sText, vbCrLf, " ", , , vbTextCompare)
      If Len(sText) Then
        lPos1 = InStr(1, sText, "<OPTION value=", vbTextCompare) + 14
        sText = Mid(sText, lPos1)
        lPos2 = InStrRev(sText, "</OPTION>", , vbTextCompare) - 1
        sText = Left(sText, lPos2)
        sText = Replace(sText, "<OPTION value=", "", , , vbTextCompare)
        sText = Replace(sText, "<OPTION selected value=", "", , , vbTextCompare)
        aTmp = Split(sText, "</OPTION>", , vbTextCompare)
        ReDim arr(1 To UBound(aTmp) + 1, 1 To 2)
        Dim strKey As String, strItem As String
        For n = 0 To UBound(aTmp)
          aVals = Split(aTmp(n), ">")
          strKey = CStr(Trim(aVals(1)))
          strItem = CStr(Trim(aVals(0)))
          Dic.Add strKey, strItem
        Next
      End If

Vậy Sheet1.[E4] = ??? nếu Sheet1.[D4] có nội dung Text trong sText
Xin cám ơn!
 

File đính kèm

  • Split sText.xls
    32.5 KB · Đọc: 25
Lần chỉnh sửa cuối:
Upvote 0
phanminhphuong đã viết:
Bạn xem giúp mình
Đã ghi yêu cầu trong file
Mã: 
VD mình lấy được Source của Website có nội dung như ô B2     (sText = Sheet1.[B2])
(tất nhiên Cell ko thể chứa được quá nhiều String)
[B][COLOR=#ff0000]
Dim sText as String
[/COLOR][/B][B][COLOR=#ff0000]sText = oInternetExplorer.Document.Body.innerHTML
[/COLOR][/B]Câu hỏi 1) xử lý biến sText như thế nào để cho kết quả ở ô E4 nếu có tương ứng Text ở D4
2) Nếu Text ở D4 ko có trong sText thì tất nhiên E4 = ""
3) Có vấn đề gì với code màu đỏ ở trên nếu Source web quá dài không ?
Mình muốn ứng dụng đoạn này mà chưa hiểu lắm
PHP: 
sText = Replace(sText, vbCrLf, " ", , , vbTextCompare)
      If Len(sText) Then
        lPos1 = InStr(1, sText, "<OPTION value=", vbTextCompare) + 14
        sText = Mid(sText, lPos1)
        lPos2 = InStrRev(sText, "</OPTION>", , vbTextCompare) - 1
        sText = Left(sText, lPos2)
        sText = Replace(sText, "<OPTION value=", "", , , vbTextCompare)
        sText = Replace(sText, "<OPTION selected value=", "", , , vbTextCompare)
        aTmp = Split(sText, "</OPTION>", , vbTextCompare)
        ReDim arr(1 To UBound(aTmp) + 1, 1 To 2)
        Dim strKey As String, strItem As String
        For n = 0 To UBound(aTmp)
          aVals = Split(aTmp(n), ">")
          strKey = CStr(Trim(aVals(1)))
          strItem = CStr(Trim(aVals(0)))
          Dic.Add strKey, strItem
        Next
      End If

Vậy Sheet1.[E4] = ??? nếu Sheet1.[D4] có nội dung Text trong sText
Xin cám ơn!
Nhấp chuột vào đây để mở rộng...

Với dữ liệu như trong file thì công thức thường cũng làm được (khỏi code)
Mã: 
=IF(COUNTIF(B2,"*>"&D4&"*"),TRIM(RIGHT(SUBSTITUTE(LEFT(B2,FIND(">"&D4,B2)-1),"value=",REPT(" ",LEN(B2))),LEN(B2))),"")
Công thức trên gõ tại cell E4
 
Upvote 0
ndu96081631 đã viết:
Với dữ liệu như trong file thì công thức thường cũng làm được (khỏi code)
Mã: 
=IF(COUNTIF(B2,"*>"&D4&"*"),TRIM(RIGHT(SUBSTITUTE(LEFT(B2,FIND(">"&D4,B2)-1),"value=",REPT("  ",LEN(B2))),LEN(B2))),"")
Công thức trên gõ tại cell E4
Nhấp chuột vào đây để mở rộng...
Bạn ơi. Mình có nói ở bài 5: ô B2 chỉ là ví dụ của giá trị biến sText thôi

sText = oInternetExplorer.Document.Body.innerHTML
mà Source của 1 Website có thể quá nhiều String so với sức chứa 1 Cell (không đủ chỗ chứa)
Do đó mình muốn viết = VBA Code để CẮT biến sText ra và đưa vào ô E4

Mình đang cố gắng sửa theo Code của bạn mà cũng ở #5 mình đã post nhưng chưa biết xử lý tiếp thế nào ???
 

File đính kèm

  • Split sText.xls
    32.5 KB · Đọc: 5
Lần chỉnh sửa cuối:
Upvote 0
phanminhphuong đã viết:
Bạn ơi. Mình có nói ở bài 5: ô B2 chỉ là ví dụ của giá trị biến sText thôi

sText = oInternetExplorer.Document.Body.innerHTML
mà Source của 1 Website có thể quá nhiều String so với sức chứa 1 Cell (không đủ chỗ chứa)
Do đó mình muốn viết = VBA Code để CẮT biến sText ra và đưa vào ô E4

Mình đang cố gắng sửa theo Code của bạn mà cũng ở #5 mình đã post nhưng chưa biết xử lý tiếp thế nào ???
Nhấp chuột vào đây để mở rộng...

Thế thì bạn phải đưa lên đây đoạn code của bạn chứ (đoạn code lấy được giá trị sText ấy). Xong thì tôi mới biết đường mà "ráp" chung vào
 
Upvote 0
Cái file của bạn không biết lấy từ đâu ra và lấy thế nào mà dữ liệu của nó không theo chuẩn DOM.

Nếu nó theo đúng chuẩn, tức là có cái root node và cái thuộc tính value nằm trong dấu nháy kép thì đã có thể dùng DOM để duyệt và lấy ra trị rất gọn gàng nhanh chóng.

Lúc đầu tôi tưởng bở, dùng code này để parse

Mã: 
Sub ParseXMLFile()
Dim xmlDoc As New MSXML2.DOMDocument
Dim optns As MSXML2.IXMLDOMNodeList, optn As MSXML2.IXMLDOMElement
Dim lngIndex As Long
xmlDoc.async = False
xmlDoc.Load "C:source web fso.txt"
Set optns = xmlDoc.getElementsByTagName("OPTION")
For lngIndex = 0 To optns.Length - 1
Set optn = optns.Item(lngIndex)
Debug.Print optn.Text; " "; optn.getAttribute("value")
Next lngIndex
End Sub

Chay hoài không ra. Xem lại thì do dữ liệu không theo chuẩn DOM. Chịu thua.

Có lẽ Internet Explorer parses HTML không cần theo sát chuẩn. Để nghiên cứu lại cái object này xem.
 
Upvote 0
Sorry bạn vì bài trước đính nhầm file chưa có Code.
Dựa trên Code của ndu mình đã viết lại như sau và chạy OK
Mã: 
Public Dic As Object
Sub Find_Value()
  Dim aTmp, aVals, arr(), sText As String, sKq As String
  Dim lPos1 As Long, lPos2 As Long, n As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  
  On Error Resume Next [COLOR=#ff0000]'Phải có vì trong Source của trang web có 1 số Text trùng nhau nên Dic.Add báo lỗi,
                                'Nếu có dòng này lấy value tương ứng Text đầu tiên tìm được[/COLOR]
  
  [E4].ClearContents
  sText = Trim([B2]) 
 [COLOR=#ff0000] '[/COLOR][COLOR=#000080][B]sText = oInternetExplorer.Document.Body.innerHTML[/B][/COLOR][COLOR=#ff0000] 'Ô B2 này có giá trị tương tự như biến sText ở dòng này,
                                     'Vì Source của 1 trang web có thể ko chứa được trong 1 ô, đây chỉ là vd 1 phần của nó[/COLOR]...
  
      sText = Replace(sText, vbCrLf, " ", , , vbTextCompare)
      If Len(sText) Then
        lPos1 = InStr(1, sText, "<OPTION value=", vbTextCompare) + 14
        sText = Mid(sText, lPos1)
        lPos2 = InStrRev(sText, "</OPTION>", , vbTextCompare) - 1
        sText = Left(sText, lPos2)
        sText = Replace(sText, "<OPTION value=", "", , , vbTextCompare)
        sText = Replace(sText, "<OPTION selected value=", "", , , vbTextCompare)
        aTmp = Split(sText, "</OPTION>", , vbTextCompare)
        ReDim arr(1 To UBound(aTmp) + 1, 1 To 2)
        Dim strKey As String, strItem As String
        For n = 0 To UBound(aTmp)
          aVals = Split(aTmp(n), ">")
          strKey = CStr(Trim(aVals(1)))
          strItem = CStr(Trim(aVals(0)))
          Dic.Add strKey, strItem
        Next
        If Dic.Count Then
          sKq = CStr([D4])
            If Dic.Exists(sKq) Then
              [E4] = Dic.Item(sKq)
            End If
        End If
      End If

End Sub
Mong các bạn góp ý thêm. Many tks
 

File đính kèm

  • Split sText.xls
    39.5 KB · Đọc: 8
Lần chỉnh sửa cuối:
Upvote 0
phanminhphuong đã viết:
Sorry bạn vì bài trước đính nhầm file chưa có Code.
Dựa trên Code của ndu mình đã viết lại như sau và chạy OK
Mã: 
Dim sText as String

  sText = Trim([B2]) 
 [COLOR=#ff0000] '[/COLOR][COLOR=#000080][B]sText = oInternetExplorer.Document.Body.innerHTML[/B][/COLOR][COLOR=#ff0000] 'Ô B2 này có giá trị tương tự như biến sText ở dòng này,
                                     'Vì Source của 1 trang web có thể ko chứa được trong 1 ô, đây chỉ là vd 1 phần của nó[/COLOR]...
Mong các bạn góp ý thêm. Many tks
Nhấp chuột vào đây để mở rộng...
Biến String có độ dài tối đa 65535 kí tự thôi bạn. Tôi thấy nhiều web có Source lớn hơn con số 65535 nhiều lần nữa. vì vậy theo mình bài này nên làm theo hướng của ndu ở #2.
Hoặc ko đặt kiểu biến cho sText (tức là Dim sText <=> Dim sText as Variant) sau khi cắt sText phù hợp thì lại convert: sText = CStr(sText)
 
Upvote 0
phanminhphuong đã viết:
Bạn ơi. Mình có nói ở bài 5: ô B2 chỉ là ví dụ của giá trị biến sText thôi

sText = oInternetExplorer.Document.Body.innerHTML
mà Source của 1 Website có thể quá nhiều String so với sức chứa 1 Cell (không đủ chỗ chứa)
Do đó mình muốn viết = VBA Code để CẮT biến sText ra và đưa vào ô E4

Mình đang cố gắng sửa theo Code của bạn mà cũng ở #5 mình đã post nhưng chưa biết xử lý tiếp thế nào ???
Nhấp chuột vào đây để mở rộng...

Bạn đã cất công lên tận trang web thì chả lý gì lại kéo cả mớ dữ liệu innerHTML về để rồi lại xoay xở "tìm tìm tách tách". Tôi đề nghị lấy nguyên dữ liệu cần lấy về để vào trong tủ (Array), khi nào cần lấy ra.

code Module1

Mã: 
Public Arr() As String

Sub Auto_Open()
    ReDim Arr(1 To 2, 1 To 1)
    GetData [B][COLOR=#ff0000]"c:\hichic.html"[/COLOR][/B]
End Sub

Sub GetData(ByVal URL As String)
Dim ie As Object
Dim oSelect As Object, opt As Object, coll_select As Object
Dim count As Long
    Set ie = CreateObject("internetexplorer.application")
    ie.Navigate URL
    Do While ie.Busy Or ie.ReadyState <> 4: DoEvents: Loop
    Set coll_select = ie.Document.all.tags("select")
    For Each oSelect In coll_select
        For Each opt In oSelect
            If Len(opt.text) Then
                count = count + 1
                ReDim Preserve Arr(1 To 2, 1 To count)
                Arr(1, count) = opt.text
                Arr(2, count) = opt.value
            End If
        Next
    Next
    Set coll_select = Nothing
    ie.Quit
    Set ie = Nothing
End Sub

Function GetOptionValue(ByVal opt_text As String) As String
Dim c As Long
    opt_text = Trim(opt_text)
    For c = 1 To UBound(Arr, 2)
        If Arr(1, c) = opt_text Then
            GetOptionValue = Arr(2, c)
            Exit For
        End If
    Next
End Function

Thay cho chỗ đỏ đỏ thì bạn nhập địa chỉ trang web.

Giả sử trong B2 bạn có text thì trong C2 bạn có value

Công thức cho C2

Mã: 
=GetOptionValue(B2)
 

File đính kèm

  • GetOptionValue.xlsm
    19.7 KB · Đọc: 12
Upvote 0
phanminhphuong đã viết:
Sorry bạn vì bài trước đính nhầm file chưa có Code.
Dựa trên Code của ndu mình đã viết lại như sau và chạy OK
Mã: 
Public Dic As Object
Sub Find_Value()
  Dim aTmp, aVals, arr(), sText As String, sKq As String
  Dim lPos1 As Long, lPos2 As Long, n As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  
  On Error Resume Next [COLOR=#ff0000]'Phải có vì trong Source của trang web có 1 số Text trùng nhau nên Dic.Add báo lỗi,
                                'Nếu có dòng này lấy value tương ứng Text đầu tiên tìm được[/COLOR]
  
  [E4].ClearContents
  sText = Trim([B2]) 
 [COLOR=#ff0000] '[/COLOR][COLOR=#000080][B]sText = oInternetExplorer.Document.Body.innerHTML[/B][/COLOR][COLOR=#ff0000] 'Ô B2 này có giá trị tương tự như biến sText ở dòng này,
                                     'Vì Source của 1 trang web có thể ko chứa được trong 1 ô, đây chỉ là vd 1 phần của nó[/COLOR]...
  
      sText = Replace(sText, vbCrLf, " ", , , vbTextCompare)
      If Len(sText) Then
        lPos1 = InStr(1, sText, "<OPTION value=", vbTextCompare) + 14
        sText = Mid(sText, lPos1)
        lPos2 = InStrRev(sText, "</OPTION>", , vbTextCompare) - 1
        sText = Left(sText, lPos2)
        sText = Replace(sText, "<OPTION value=", "", , , vbTextCompare)
        sText = Replace(sText, "<OPTION selected value=", "", , , vbTextCompare)
        aTmp = Split(sText, "</OPTION>", , vbTextCompare)
        ReDim arr(1 To UBound(aTmp) + 1, 1 To 2)
        Dim strKey As String, strItem As String
        For n = 0 To UBound(aTmp)
          aVals = Split(aTmp(n), ">")
          strKey = CStr(Trim(aVals(1)))
          strItem = CStr(Trim(aVals(0)))
          Dic.Add strKey, strItem
        Next
        If Dic.Count Then
          sKq = CStr([D4])
            If Dic.Exists(sKq) Then
              [E4] = Dic.Item(sKq)
            End If
        End If
      End If

End Sub
Mong các bạn góp ý thêm. Many tks
Nhấp chuột vào đây để mở rộng...

Vầy đi cho gọn!
Giả định bạn đã có sText (lấy từ đâu đó). Giờ ta viết thêm 1 hàm:
Mã: 
Function LookupTxt(ByVal lookup_Value, ByVal sText As String) As String
  Dim tmp As String, lPos As Long
  On Error Resume Next
  tmp = Trim(sText)
  If Len(tmp) Then
    If Len(lookup_Value) Then
      lPos = InStrRev(tmp, ">" & lookup_Value & "</OPTION>", , vbTextCompare) - 1
      If lPos > 0 Then
        tmp = Left(tmp, lPos)
        lPos = InStrRev(tmp, "value=", , vbTextCompare) + 6
        If lPos > 0 Then LookupTxt = Trim(Mid(tmp, lPos))
      End If
    End If
  End If
End Function
Còn Sub Find_Value của bạn sửa thành:
Mã: 
Sub Find_Value()
  Dim sText As String, lookup_Value As String, sRet As String
  Range("E4").ClearContents
  lookup_Value = Range("D4")
  [COLOR=#ff0000]sText = Range("B2").Value[/COLOR] '<--- Cho này là ket qua lay tu Web
  sRet = LookupTxt(lookup_Value, sText)
  If Len(sRet) Then Range("E4").Value = sRet
End Sub
Xong!
 
Upvote 0
Cảm ơn bạn siwtom và ndu nhiêu.
Còn về vấn đề Dim sText as String thì len(sText) chỉ tối đa 65535 kí tự?
như vậy dùng biến String để chứa Source web có thể bị lỗi tràn biến?
vậy theo bạn otonhot thì mình Dim sText sau khi cắt xong thì sText = CStr(sText), như vậy chắc là ổn?
 
Upvote 0
phanminhphuong đã viết:
vậy theo bạn otonhot thì mình Dim sText sau khi cắt xong thì sText = CStr(sText), như vậy chắc là ổn?
Nhấp chuột vào đây để mở rộng...
Tôi cũng không hình dung được công việc của bạn là gì nên không dám nói chắc, Tuy nhiên ta có thể thí nghiệm, tới đâu tính tới đó ---> Chuyện nhỏ
 
Upvote 0
otonhot đã viết:
Biến String có độ dài tối đa 65535 kí tự thôi bạn. Tôi thấy nhiều web có Source lớn hơn con số 65535 nhiều lần nữa. vì vậy theo mình bài này nên làm theo hướng của ndu ở #2.
Hoặc ko đặt kiểu biến cho sText (tức là Dim sText <=> Dim sText as Variant) sau khi cắt sText phù hợp thì lại convert: sText = CStr(sText)
Nhấp chuột vào đây để mở rộng...

String trong VBA là dạng độ dài động. Loại biến này dùng 4 bytes để ghi độ dài cho nên có thể dài đến 2 tỷ ký tự

64k là giới hạn độ dài của loại string cố định, dùng 2 bytes để ghi độ dài. Loại này được khia báo theo ngữ pháp:
Dim s As String * n (n là độ dài đã xác định)

Rất hiếm trang web có dữ liệu text nhiều hơn 2 Gig. Cho nên dùng biến string được.
 
Upvote 0
VetMini đã viết:
String trong VBA là dạng độ dài động. Loại biến này dùng 4 bytes để ghi độ dài cho nên có thể dài đến 2 tỷ ký tự

64k là giới hạn độ dài của loại string cố định, dùng 2 bytes để ghi độ dài. Loại này được khia báo theo ngữ pháp:
Dim s As String * n (n là độ dài đã xác định)

Rất hiếm trang web có dữ liệu text nhiều hơn 2 Gig. Cho nên dùng biến string được.
Nhấp chuột vào đây để mở rộng...
Bạn VietMini có những kiến thức thật sâu sắc, tỉ mỉ. Chắc chắn phải tìm tòi nghiên cứu nhiều mới có được.
Một lần nữa chân thành cám ơn các bạn.

Nhân tiện các bạn cho mình hỏi có tài liệu hoặc trang web nào hướng dẫn cách lấy và thao tác với dữ liệu/ source của web không, xin chỉ giúp mình!
Vì các trang web viết bằng nhiều ngôn ngữ lập trình khác nhau mà mình đang có nhu cầu tìm hiểu VBA thao tác với các web = IE như thế nào,
vd trang web có nhúng java, flash ... thì thao tác với nhiều đối tượng khác nhau đó như thế nào ? và nhiều thứ khác nữa...
Many tks
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

B
  • Question
Chuyển đổi dữ liệu sạng dạng mảng
Trả lời
5
Đọc
79
ongke0711
ongke0711
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
Trả lời
11
Đọc
155
ho van luong
H
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
6
Đọc
136
Hoàng Tuấn 868
H
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
0
Đọc
59
shnhatha221108
S
T
Không hiện dữ liệu ở ô công thức
Trả lời
3
Đọc
72
thien-16
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom