- ©«¤l
- 184
- ¥DÃD
- 45
- ºëµØ
- 0
- ¿n¤À
- 407
- ÂI¦W
- 0
- §@·~¨t²Î
- WIN 7
- ³nÅ骩¥»
- office 2010
- ¾\ŪÅv
- 20
- ©Ê§O
- ¨k
- µù¥U®É¶¡
- 2010-8-19
- ³Ì«áµn¿ý
- 2024-11-1
|
- Sub ¸ü¤J¼Æ¾Ú_¥þ³¡()
- Dim y&, Ym&
- Set MySht = Sheets("¬d¸ßªí")
- y = MySht.[A65536].End(xlUp).Row: If y < 4 Then Exit Sub
- MySht.[B4:IV65536].ClearContents
- MySht.[A2] = "¡Ö¡Ö¡Ö¡Ö¡Ö¸ê®Æ¸ü¤J¤¤¡A½ÐµyÔ......"
- Application.ScreenUpdating = False
- For Each uRng In MySht.Range("A4:A" & y)
- Ym = Ym + 1
- Application.StatusBar = "¡½¡½¡½°õ¦æ¼Æ¾Ú¸ü¤J¤¤¡D" & Ym & "/" & y - 3
- If uRng <> "" Then Call ¨ú±oӪѸê°T
- Next
- MySht.Select
- Application.StatusBar = False
- MySht.[A2] = ""
- Call ӪѸê°T®æ¦¡³]©w: Beep
- End Sub
- Sub ¸ü¤J¼Æ¾Ú_ÓªÑ()
- Set MySht = Sheets("¬d¸ßªí")
- Set uRng = ActiveCell
- If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
- MsgBox "¡°½Ð¥ý¿ï¨úӪѽs¸¹¡I": Exit Sub
- End If
- Application.ScreenUpdating = False
- Call ¨ú±oӪѸê°T: Call ӪѸê°T®æ¦¡³]©w
- If GetInfo = "ERR" Then uRng(1, 2) = "¡mµL¸ê®Æ¡n"
- MySht.Select
- Beep
- End Sub
- Sub ¬d¬ÝӪѸê°T()
- Set MySht = Sheets("¬d¸ßªí")
- Set uRng = ActiveCell
- If uRng.Row < 4 Or uRng.Column > 1 Or uRng = "" Then
- MsgBox "¡°½Ð¥ý¿ï¨úӪѽs¸¹¡I": Exit Sub
- End If
- Application.ScreenUpdating = False
- Call ¶×¤J¤å¦rÀÉ: Call ӪѸê°T®æ¦¡³]©w
- If GetInfo = "ERR" Then uRng(1, 2) = "¡mµL¸ê®Æ¡n"
- End Sub
- Sub ¶×¤J¤å¦rÀÉ()
- Dim uObj As Object, uFF As Object
- GetInfo = ""
- uFile = ThisWorkbook.Path & "\TextFile\" & uRng.Text & ".txt"
- If Dir(uFile) = "" Then GetInfo = "ERR": Exit Sub
- Set uObj = CreateObject("Scripting.FileSystemObject")
- Set uFF = uObj.OpenTextFile(uFile)
- XMLText = uFF.Readall: uFF.Close: Call ©ñ¤J°Å¶Kï
- With Sheets("ӪѸê°T")
- Application.Goto .[A1], True: .Cells.Clear
- .[B1].Select: .Paste: [B1].Select
- .[B1].Replace " *", "", Lookat:=xlPart
- End With
- End Sub
- Sub ӪѸê°T®æ¦¡³]©w()
- With Sheets("ӪѸê°T").UsedRange
- .Borders.LineStyle = 1: .ColumnWidth = 13: .RowHeight = 13.5
- .Font.Size = 10: .Font.Name = "·s©ú²ÓÅé": .WrapText = False
- End With
- End Sub
- Sub ¨ú±oӪѸê°T()
- Dim fRng As Range, uTxt$, i&, j&, Jm%, xR As Range, xC%
- uRng(1, 2).Resize(1, 40).ClearContents
- xC = MySht.[IV3].End(xlToLeft).Column: If xC = 1 Then Exit Sub
- Set WebSht = Sheets("ӪѸê°T")
- Call ¶×¤J¤å¦rÀÉ
- If GetInfo = "ERR" Then uRng(1, 2) = "¡mµL¸ê®Æ¡n": Exit Sub
- If InStr(WebSht.[B1], uRng) = 0 Then uRng(1, 2) = "¡mµL¸ê®Æ¡n": Exit Sub
- '-----------------------------------------
- uRng(1, 2).Value = WebSht.[B1]
- uRng(1, 2).Replace uRng, ""
- '-----------------------------------------
- For j = 3 To xC
- uTxt = MySht.Cells(3, j): If uTxt = "" Then GoTo 101
- Set fRng = WebSht.Cells.Find(uTxt, Lookat:=xlPart)
- If fRng Is Nothing Then GoTo 101
- If uTxt = "²{ª÷ªÑ§Q" Or uTxt = "¦Xp" Then
- uRng(1, j).Resize(1, 4).Value = Application.Transpose(fRng(2, 2).Resize(4, 1).Value)
- ElseIf uTxt = "¨CªÑ²bÈ" Then
- With uRng(1, j): .Value = fRng: .Replace "¨CªÑ²bÈ:* ", "": End With
- Else
- uRng(1, j) = fRng(1, 6)
- End If
- 101: Next j
- '-----------------------------------------
- uRng(1, 6).Resize(1, xC).Replace "¤¸", ""
- End Sub
- Sub ©ñ¤J°Å¶Kï() '±N¨ú±o¤å¦r©ñ¤J°Å¶Kï
- '¡e°Å¶Kï¡f³]©w¤Þ¥Î¶µ¥Ø Microsoft Forms 2.0 Object Library
- Dim DOB As New DataObject
- With DOB: .Clear: .SetText XMLText: .PutInClipboard: End With
- End Sub
- Sub ²M°£()
- If MsgBox("¡°½T©wn²M°£¥þ³¡¤º®e¶Ü¡H", 4 + 32 + 256) = vbNo Then Exit Sub
- [B4:IV65536].ClearContents
- End Sub
½Æ»s¥N½X ³o¬O§Ú¬Q¤Ñק諸¤è¦¡
µ¹¦U¦ì°Ñ¦Ò¬Ý¬Ý |
|