ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

¸ü¤J¾ú¦~ªÑ§Q¬Fµ¦

¸ü¤J¾ú¦~ªÑ§Q¬Fµ¦

±z¦n
´N±Ð¦U¦ì
³o¤@¥÷¸ê®Æ¬O§Ú¦bºô¸ô¤W§ä¨ìªº
²{¦b§Ú­n§â¥¦­×§ï¦¨¥i¥H¸ü¤J¦UªÑ10¦~ªÑ§Q
¸ê®Æ¤U¸ü³B§Ú¤w¸g­×§ï¹L¤F
¦ý§Ú²{¦b¤£·|§âTXTÀÉ¡¨¦X­p¡¨ªº¸ê®Æ¸ü¤J
¦³¤H¥i¥HÀ°§Ú¹À
ÁÂÁÂ!!

TEST.rar (83.2 KB)

TEST.rar (83.2 KB)

¦^´_ 1# pupai
¸Õ¸Õ¬Ý
  1. Option Explicit
  2. Const ¸ê°T = "­ÓªÑ¸ê°T"
  3. Const ¥Dªí = "¬d¸ßªí"
  4. Sub ¸ü¤J¥þ³¡¼Æ¾Ú()
  5.     Dim Rng As Range, e As Range
  6.     With Sheets(¥Dªí)
  7.         .Range(.[a4], .[a4].End(xlDown)).Offset(, 1).Resize(, 11) = ""
  8.         For Each e In .Range(.[a4], .[a4].End(xlDown))
  9.             ¼Æ¾Ú e
  10.         Next
  11.      End With
  12. End Sub
  13. Sub ¸ü¤J­ÓªÑ¼Æ¾Ú()
  14.     ¼Æ¾Ú ActiveCell
  15.     ActiveCell.Resize(, 12).Select
  16. End Sub
  17. Private Sub ¼Æ¾Ú(xRng As Range)
  18.     Dim xUrl As String
  19.      If xRng.Parent.Name <> ¥Dªí Then MsgBox "½Ð¿ï¾Ü " & ¥Dªí & " ªº­ÓªÑ½s¸¹ ½d³ò  ": Exit Sub
  20.      With Sheets(¥Dªí)
  21.         If Intersect(.Range(.[a4], .[a4].End(xlDown)), xRng) Is Nothing Then MsgBox "½Ð¿ï¾Ü " & ¥Dªí & " ªº­ÓªÑ½s¸¹ ½d³ò  ": Exit Sub
  22.     End With
  23.     xUrl = "URL;http://tw.stock.yahoo.com/d/s/dividend_" & xRng & ".html"
  24.     With Sheets(¸ê°T)
  25.         If .QueryTables.Count <> 0 Then
  26.             .QueryTables(1).Connection = xUrl
  27.         Else
  28.         .QueryTables.Add xUrl, .[A1]
  29.         End If
  30.         With .QueryTables(1)
  31.             .WebSelectionType = xlSpecifiedTables
  32.             .WebTables = "7,10"
  33.             .Refresh BackgroundQuery:=False
  34.             xRng.Cells(1, 2) = Replace(Split(.ResultRange.Cells(1, 1), " ")(0), xRng, "")
  35.             xRng.Cells(1, 3).Resize(, 10) = Application.WorksheetFunction.Transpose(.ResultRange.Cells(6, 6).Resize(10))
  36.             xRng.Cells(1, 3).Resize(, 10).NumberFormatLocal = "G/³q¥Î®æ¦¡"
  37.         End With
  38.     End With
  39.     Beep
  40. End Sub
½Æ»s¥N½X
·P®¦ªº¤ß......(¦b³Â»¶®a±Ú°Q½×°Ï.¥Î¤ß¾Ç²ß·|¦³¶i¨Bªº)
¦ý¸ê·½µL­­,«á´©¦³­­,  ¤@¤Ñ1¤¸ªºÃÙ§U,¤H¤H¦³¯à¤O.

TOP

¦^´_ 2# GBKEE

·PÁª©¤j
§Ú¦b¬ã¨s¬Ý¬Ý

TOP

  1. Sub ¸ü¤J¼Æ¾Ú_¥þ³¡()
  2. Dim y&, Ym&
  3. Set MySht = Sheets("¬d¸ßªí")
  4. y = MySht.[A65536].End(xlUp).Row:  If y < 4 Then Exit Sub
  5. MySht.[B4:IV65536].ClearContents
  6. MySht.[A2] = "¡Ö¡Ö¡Ö¡Ö¡Ö¸ê®Æ¸ü¤J¤¤¡A½Ðµy­Ô......"
  7. Application.ScreenUpdating = False
  8. For Each uRng In MySht.Range("A4:A" & y)
  9.     Ym = Ym + 1
  10.     Application.StatusBar = "¡½¡½¡½°õ¦æ¼Æ¾Ú¸ü¤J¤¤¡D" & Ym & "/" & y - 3
  11.     If uRng <> "" Then Call ¨ú±o­ÓªÑ¸ê°T
  12. Next
  13. MySht.Select
  14. Application.StatusBar = False
  15. MySht.[A2] = ""
  16. Call ­ÓªÑ¸ê°T®æ¦¡³]©w: Beep
  17. End Sub

  18. Sub ¸ü¤J¼Æ¾Ú_­ÓªÑ()
  19. Set MySht = Sheets("¬d¸ßªí")
  20. Set uRng = ActiveCell
  21. If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
  22.    MsgBox "¡°½Ð¥ý¿ï¨ú­ÓªÑ½s¸¹¡I":   Exit Sub
  23. End If
  24. Application.ScreenUpdating = False
  25. Call ¨ú±o­ÓªÑ¸ê°T: Call ­ÓªÑ¸ê°T®æ¦¡³]©w
  26. If GetInfo = "ERR" Then uRng(1, 2) = "¡mµL¸ê®Æ¡n"
  27. MySht.Select
  28. Beep
  29. End Sub

  30. Sub ¬d¬Ý­ÓªÑ¸ê°T()
  31. Set MySht = Sheets("¬d¸ßªí")
  32. Set uRng = ActiveCell
  33. If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
  34.    MsgBox "¡°½Ð¥ý¿ï¨ú­ÓªÑ½s¸¹¡I":   Exit Sub
  35. End If
  36. Application.ScreenUpdating = False
  37. Call ¶×¤J¤å¦rÀÉ: Call ­ÓªÑ¸ê°T®æ¦¡³]©w
  38. If GetInfo = "ERR" Then uRng(1, 2) = "¡mµL¸ê®Æ¡n"
  39. End Sub

  40. Sub ¶×¤J¤å¦rÀÉ()
  41. Dim uObj As Object, uFF As Object
  42. GetInfo = ""
  43. uFile = ThisWorkbook.Path & "\TextFile\" & uRng.Text & ".txt"
  44. If Dir(uFile) = "" Then GetInfo = "ERR": Exit Sub
  45. Set uObj = CreateObject("Scripting.FileSystemObject")
  46. Set uFF = uObj.OpenTextFile(uFile)
  47. XMLText = uFF.Readall: uFF.Close:  Call ©ñ¤J°Å¶Kï
  48. With Sheets("­ÓªÑ¸ê°T")
  49.      Application.Goto .[A1], True:  .Cells.Clear
  50.      .[B1].Select: .Paste: [B1].Select
  51.      .[B1].Replace " *", "", Lookat:=xlPart
  52. End With
  53. End Sub

  54. Sub ­ÓªÑ¸ê°T®æ¦¡³]©w()
  55. With Sheets("­ÓªÑ¸ê°T").UsedRange
  56.      .Borders.LineStyle = 1:  .ColumnWidth = 13: .RowHeight = 13.5
  57.      .Font.Size = 10: .Font.Name = "·s©ú²ÓÅé": .WrapText = False
  58. End With
  59. End Sub

  60. Sub ¨ú±o­ÓªÑ¸ê°T()
  61. Dim fRng As Range, uTxt$, i&, j&, Jm%, xR As Range, xC%
  62. uRng(1, 2).Resize(1, 40).ClearContents
  63. xC = MySht.[IV3].End(xlToLeft).Column: If xC = 1 Then Exit Sub
  64. Set WebSht = Sheets("­ÓªÑ¸ê°T")
  65. Call ¶×¤J¤å¦rÀÉ
  66. If GetInfo = "ERR" Then uRng(1, 2) = "¡mµL¸ê®Æ¡n": Exit Sub
  67. If InStr(WebSht.[B1], uRng) = 0 Then uRng(1, 2) = "¡mµL¸ê®Æ¡n": Exit Sub
  68. '-----------------------------------------
  69. uRng(1, 2).Value = WebSht.[B1]
  70. uRng(1, 2).Replace uRng, ""
  71. '-----------------------------------------
  72. For j = 3 To xC
  73.     uTxt = MySht.Cells(3, j): If uTxt = "" Then GoTo 101
  74.     Set fRng = WebSht.Cells.Find(uTxt, Lookat:=xlPart)
  75.     If fRng Is Nothing Then GoTo 101
  76.     If uTxt = "²{ª÷ªÑ§Q" Or uTxt = "¦X­p" Then
  77.        uRng(1, j).Resize(1, 4).Value = Application.Transpose(fRng(2, 2).Resize(4, 1).Value)
  78.     ElseIf uTxt = "¨CªÑ²b­È" Then
  79.        With uRng(1, j): .Value = fRng: .Replace "¨CªÑ²b­È:* ", "": End With
  80.     Else
  81.        uRng(1, j) = fRng(1, 6)
  82.     End If
  83. 101: Next j
  84. '-----------------------------------------
  85. uRng(1, 6).Resize(1, xC).Replace "¤¸", ""
  86. End Sub

  87. Sub ©ñ¤J°Å¶Kï() '±N¨ú±o¤å¦r©ñ¤J°Å¶Kï
  88. '¡e°Å¶Kï¡f³]©w¤Þ¥Î¶µ¥Ø Microsoft Forms 2.0 Object Library
  89. Dim DOB As New DataObject
  90. With DOB: .Clear: .SetText XMLText: .PutInClipboard: End With
  91. End Sub

  92. Sub ²M°£()
  93. If MsgBox("¡°½T©w­n²M°£¥þ³¡¤º®e¶Ü¡H", 4 + 32 + 256) = vbNo Then Exit Sub
  94. [B4:IV65536].ClearContents
  95. End Sub
½Æ»s¥N½X
³o¬O§Ú¬Q¤Ñ­×§ïªº¤è¦¡
µ¹¦U¦ì°Ñ¦Ò¬Ý¬Ý

TOP

        ÀR«ä¦Û¦b : ¶¢¤HµL¼Ö½ì¡A¦£¤HµL¬O«D¡C
ªð¦^¦Cªí ¤W¤@¥DÃD