- ©«¤l
- 96
- ¥DÃD
- 18
- ºëµØ
- 0
- ¿n¤À
- 125
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Office 2007
- ¾\ŪÅv
- 20
- ©Ê§O
- ¨k
- µù¥U®É¶¡
- 2014-3-23
- ³Ì«áµn¿ý
- 2022-8-2
|
¦^´_ 27# GBKEE
GBKEEª©¥D¦¦w¡A¦³¨Ç°ÝÃD·Q½Ð±Ð±z¡G
1.¤µ¦¤U¯Z¦^¨Ó´N°¨¤W¸Õ¤F±z¬Q¤Ñ¦b27#´£¨Ñªºµ{¦¡½X¡A§Ú¦³¦A¥[¤Wn¸õ¹Lªº¥N¸¹¦bAR¤¤¡A¤]·Ó´£¥Ü±N¥N¸¹³£¿é¤J¨ìsheet(2)ªºAÄæ
ª½±µ¶]¤@¦¸¡A©_©Çªº¨Æµo¥Í¤F¡A§Ú³]©wFor E = 1101 to 5000¡A¨C¦¸¶]¨ì¤@¥b®É´N·|¥X¿ù¡A¥X¿ùªº¦ì¸m¬O¦bIf UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then¡A¤£²M·¡þ¸Ì¥X¤F°ÝÃD
ªþ¤Wµ{¦¡½X©MÀɮסA½Ð±zÀ°¦£¬Ý¬Ý¡@
2.¥t¥~§Ú¦³µo²{±z27#ªºµ{¦¡½X¦b¥X¿ù«eªº°õ¦æ®É³t«×«D±`§Ö¡A©M±z¥ý«e´£¨Ñªºµ{¦¡½XÅý§Ú¦b23#§¹¦¨ªºµ{¦¡¦³«Ü¤jªº¸¨®t¡A³o·í¤¤¨s³º¦³¤°»ò®t²§©O¡H¬°¤°»ò³t«×·|®t³o»ò¦h©O¡H
¤@¼Ë§Ú¨âÓVBAµ{¦¡³£¦³ªþ¤W¡A¤]³Â·Ð±zÀ°¦£¬Ý¬Ý¬°¤°»ò·|¦³¦p¦¹¤jªº®t²§
3.§Ú¥Î±z¥ý«e´£¨Ñªº¶]¤U¨Ó¡A²Ä¤@¬q1101 to 5000¡A¶O®É12¤À48¬í¡A§ì¤F992µ§¸ê®Æ
²Ä¤G¬q5001 to 9962¡A¶O®É13¤À50¬í¡A§ì¤F515µ§¸ê®Æ
§Ú¦b¶]²Ä¤G¬q®É¦³¥ý¨Ï¥Î²M°£¨t²Îªº.batÀÉ¡A¨Ã±NEXCELÃö³¬¦A¶}±Ò«·s°õ¦æVBA¡Aµ²ªG¬Ý¨Ó¨Ã¨S¦³½G¨ªº®ÄªG¡A¤£ª¾¹D¬°¤°»ò·|³o¼Ë¡H
4.¥t¥~¦b±N¸ê®Æ¶×¤Jtxtªºµ{¦¡½X¤¤¡A¦p¤U
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
¨ä¤¤Q.ResultRange.RowsªºRows¬O¤£¬O¥Nªí¦C¡A¤]´N¬O±N¸ê®Æ¤@¦C¤@¦C¦s¤Jtxt¡Aª½¨ì¨S¦³¸ê®Æ¬°¤î
¤§«á§Ú¦³·Q¨ì¡A¦]¬°¥Î¤@¦C¤@¦Cªº¤è¦¡¨Ó¶×¤J¸ê®Æn¶]«Ü¦h¦¸°j°é¡A¦pªG¬O¥Î¤@Äæ¤@Ä檺¤è¦¡¶×¤J´N·|¤Ö¶]«Ü¦h¦¸°j°é
§Ú¦³¸ÕµÛ±NRows§ï¬°Columns¡A¦ý°õ¦æ¨ì¤U¤G¦æªºC = Join(C, vbTab)´N·|¥X¿ù¡A¤£ª¾¹D¦³¨S¦³¿ìªk¥ÎÄ檺¤è¦¡¶×¤J©O¡H
°ÝÃD¦³ÂI¦h¡A¦A³Â·Ð±zÀ°¦£¤@¤UÅo¡I·PÁ¡I- Option Explicit
- Sub §ì©u¤ëÀ禬¸ê®Æ()
- Dim E As Integer, URL As String, xPath As String, xFile As String
- Dim i As Integer, ii As Integer, Rng As Range, S1 As String, S2 As String, t As Date
- Dim AR()
- t = Time
- AR = Array(1202, 1420, 1433, 1502, 1518, 1610, 1716, 2346, 2372, 2391, 2513, 2526, 2541, 2802, 2803, 2804, 2806, _
- 2813, 2814, 2815, 2817, 2818, 2819, 2821, 2826, 2830, 2839, 2840, 2843, 2844, 2848, 2907, 2909, 4101, 4112, _
- 4175, 4201, 4203, 4204, 4301, 4302, 4405, 4407, 4409, 4410, 4411, 4412, 4504, 4505, 4507, 4508, 4509, 4512, _
- 4514, 4516, 4517, 4519, 4520, 4521, 4524, 4525, 4531, 4603, 4604, 4605, 4606, 4607, 4608, 4701, 4704, 4705, _
- 4708, 4709, 4710, 4713, 4715, 4718, 4901, 4902, 5001, 5003, 5004, 5005, 5012, 5101, 5311, 5319, 5320, 5322, _
- 5323, 5327, 5330, 5331, 5334, 5335, 5337, 5341, 5342, 5354, 5357, 5358, 5359, 5360, 5361, 5362, 5363, 5366, _
- 5368, 5369, 5374, 5377, 5379, 5380, 5382, 5389, 5391, 5393, 5394, 5396, 5397, 5399, 5404, 5405, 5408, 5409, _
- 5411, 5412, 5415, 5416, 5417, 5418, 5419, 5420, 5421, 5422, 5423, 5424, 5427, 5428, 5430, 5431, 5433, 5435, _
- 5440, 5444, 5445, 5446, 5447, 5449, 5453, 5456, 5458, 5459, 5461, 5462, 5463, 5470, 5472, 5476, 5477, 5482, _
- 5485, 5486, 5495, 5496, 5499, 5509, 5517, 5527, 5606, 5705, 5804, 5805, 5806, 5807, 5809, 5812, 5814, 5815, _
- 5854, 6003, 6006, 6019, 6102, 6106, 6401, 6501, 8001, 8003, 8903, 8904, 8912, 8914, 8915, 8918, 8920, 8922, 8939, 9105, 9909)
- '¿é¤J 4203¤Ñ¤¯(«á§ì¨ú)¬O¿ù»~ªºªÑ²¼¸¹½X
- URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
- xPath = "G:\°]³ø¸ê®Æ"
- With ThisWorkbook
- .Sheets(2).UsedRange.Offset(, 1).Clear
- '4203¤Ñ¤¯(«á§ì¨ú)¬O¿ù»~ªºªÑ²¼¸¹½X ³o¨Ç ªÑ²¼¦WºÙ(¥N¸¹) ³sÄò¤@°_¿é¤J¦bSheets(2)ªºAÄæ
- Set Rng = .Sheets(2).Range("A:A").SpecialCells(xlCellTypeConstants)
- If Rng Is Nothing Then
- AR = Array()
- ElseIf Rng.Count = 1 Then
- AR = Array(Rng.Value)
- Else
- AR = Application.Transpose(Application.Transpose(Rng))
- End If '***************************************************
- Application.ScreenUpdating = False
- Application.StatusBar = " "
- With .Sheets(1) '¬¡¶Ã¯ªº²Ä 1 ±i¤u§@ªí
- If .QueryTables.Count = 0 Then
- With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
- .Refresh BackgroundQuery:=False
- End With
- End If
- .Rows(1).Delete
- .Columns(1).Delete
- For E = 1101 To 5000
- With .QueryTables(1)
- .Connection = URL & E
- .PreserveFormatting = True
- .BackgroundQuery = True
- .RefreshStyle = xlInsertDeleteCells
- .SaveData = True
- .AdjustColumnWidth = True
- .RefreshPeriod = 0
- .WebSelectionType = xlSpecifiedTables
- .WebFormatting = xlWebFormattingNone
- .WebTables = "3"
- .WebPreFormattedTextToColumns = True
- .WebConsecutiveDelimitersAsOne = True
- .Refresh BackgroundQuery:=False
- If .ResultRange(1) < 0 Or InStr(.ResultRange(2, 1), "¬dµL") Then GoTo xLnext
- '¶×¤J¸ê®Æªº A1 < 0 OR ¶×¤J¸ê®Æªº A2 "¬dµL"
- S1 = .ResultRange(1)
- S2 = Mid(S1, 1, InStr(S1, "(") - 1) 'ªÑ²¼¦WºÙ
- End With
- With ThisWorkbook.Sheets(2).Range("B:B")
- Set Rng = .Find(S2, lookat:=xlPart) '·j´M:ªÑ²¼¦WºÙ
- If Rng Is Nothing Then
- i = i + 1
- .Range("A" & i) = S1 'ªÑ²¼¦WºÙ¥N½X
- Else
- Rng.Cells(1, 2) = S1 '«½ÆªºªÑ²¼
- If UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then
- 'Filter(AR, E) > -1 '¤ñ¹ï¨ì¦p4203¤Ñ¤¯(«á§ì¨ú)¬O¿ù»~
- Rng.Cells(1, 2) = Rng.Cells(1, 2) & "***" '«á§ì¨ú¬O¿ù»~
- GoTo xLnext:
- End If
- S2 = Mid(Trim(Rng), InStr(Trim(Rng), "(") + 1)
- S2 = Mid(S2, 1, Len(S2) - 1) 'ªºªÑ²¼[¥N½X]
- xFile = xPath & "\" & S2 & "\*.*" '±þ±¼©Ò¦³ÀÉ®×
- If Dir(xFile) <> "" Then
- ii = ii - 1
- Kill xFile
- xFile = xPath & "\" & S2
- If Dir(xFile, vbDirectory) <> "" Then RmDir xFile '¸ê®Æ§¨¤]§R°£¤F
- End If
- End If
- End With
- ii = ii + 1
- xFile = xPath & "\" & E & "\REVENUE.txt"
- MkDir_Sub xFile
- Maketxt xFile, .QueryTables(1)
- xLnext:
- S1 = " " & Sheets(1).QueryTables(1).ResultRange(1)
- If Val(S1) < 0 Then S1 = " ¬dµL"
- Application.StatusBar = Application.Text(Time - t, ["MM¤ÀSS¬í"]) & " " & E & S1
- Next
- End With
- End With
- Application.ScreenUpdating = True
- Application.StatusBar = Application.Text(Time - t, ["MM¤ÀSS¬í"]) & " Ok "
- MsgBox "¶×¤J ¤å¦rÀÉ" & ii & " ¶O®É " & Application.Text(Time - t, ["MM¤ÀSS¬í"])
- End Sub
- Private Sub MkDir_Sub(s As String)
- Dim AR, i As Integer, xPath As String
- If Dir(s) = "" Then
- AR = Split(s, "\")
- xPath = AR(0)
- For i = 1 To UBound(AR) - 1
- xPath = xPath & "\" & AR(i)
- If Dir(xPath, vbDirectory) = "" Then MkDir xPath
- Next
- End If
- End Sub
- Private Sub Maketxt(xF As String, Q As QueryTable) '±N¶×¤J¸ê®Æ¦s¤J«ü©wªºtxt
- Dim fs As Object, E As Range, C As Variant
- Set fs = CreateObject("Scripting.FileSystemObject")
- Set fs = fs.CreateTextFile(xF, True) '³Ð¨£¤@ÓÀÉ®×,¦pÀɮצs¦b¥iÂл\±¼
- For Each E In Q.ResultRange.Rows
- C = Application.Transpose(Application.Transpose(E.Value))
- C = Join(C, vbTab)
- fs.WriteLine C
- Next
- fs.Close
- End Sub
½Æ»s¥N½X
¨âÓ¤ëÀ禬VBA.zip (38.38 KB)
|
|