返回列表 上一主題 發帖

[發問] VBA 開啟檔案應用

回復 3# Jason80Lo
參考一下
同一個[一般模組]的程式碼
  1. Option Explicit
  2. Dim Msg As Boolean, xTime As Variant
  3. '一般模組:檔案開啟時自動執行的程序
  4. Sub AUTO_OPEN()  '兩個按鈕〔開始〕
  5.     If Msg = True Then Exit Sub
  6.     Msg = True
  7.     Ex
  8. End Sub
  9. '一般模組:檔案關閉時自動執行的程序
  10. Sub AUTO_CLOSE() '兩個按鈕,[ 停止〕
  11.      Msg = False
  12.      If xTime <> "" Then
  13.         Application.OnTime xTime, "Ex", Schedule:=False  '關閉下一個OnTime的執行
  14.         '這檔案關閉後,Excel沒關閉還是會執行OnTime的程式,會再度開啟這檔案
  15.         xTime = ""
  16.      End If
  17.      ActiveWorkbook.Save  '使用中活頁簿存檔
  18. End Sub
  19. Private Sub Ex()
  20.     Dim xPath As String, Rng(1 To 2) As Range, xFile As String, i As Integer
  21.     Dim xString
  22.     xPath = "d:\test\"  'txt 檔案的目錄
  23.     Set Rng(1) = ActiveWorkbook.Sheets("Sheet1").Rows(1)  ''使用中活頁簿,這工作表的第一列
  24.     xFile = Dir(xPath & "\*.txt")          '搜尋附檔名
  25.     Do While xFile <> ""                   '找到
  26.         Set Rng(2) = Rng(1).Find(xFile, LookAT:=xlWhole) '比對第一列中的 txt檔
  27.         If Rng(2) Is Nothing Then                        '第一列中比對沒有這txt檔
  28.             i = 1
  29.            With Rng(1).Cells(Application.CountA(Rng(1)) + 1) '依序在第一列中
  30.                 .Cells = xFile                  '檔名寫入儲存格中
  31.                 Open xPath & xFile For Input Access Read As #1  '開啟文字檔
  32.                 Do Until EOF(1)                 '執行迴圈直到檔尾為止。
  33.                     Line Input #1, xString      '將資料讀入變數中。
  34.                     .Cells(3 + i, 1) = xString  '變數寫入儲存格中
  35.                     i = i + 1
  36.                 Loop
  37.                 Close #1    ' 關閉檔案。
  38.             End With
  39.         End If
  40.         xFile = Dir         '查下一個 txt檔
  41.     Loop
  42.     xTime = Int(Application.Text(Time, "[m]") / 5) + 1  '現在時間的分鐘數/5  的整數+ 1
  43.     xTime = DateAdd("N", 5 * xTime, 0)                  '下一個5分整
  44.     Application.OnTime xTime, "Ex"
  45.     Application.StatusBar = "下次執行時間 " & xTime
  46. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 8# Jason80Lo
d:\test\

   
  1. xPath = "d:\test\"  'txt 檔案的目錄
複製代碼
  1. MsgBox xPath & xFile '看看
  2. Open xPath & xFile For Input Access Read As #1  
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 10# Jason80Lo
試看看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim xTime As Variant
  4.     Application.VBE.Windows("即時運算").Visible = True
  5.     '30秒、30分、3小時
  6.     xTime = Int(Application.Text(Time, "[s]") / 30) + 1
  7.     xTime = DateAdd("s", 30 * xTime, 0)
  8.     Debug.Print "下一個30秒整", Time, xTime
  9.     xTime = Int(Application.Text(Time, "[m]") / 30) + 1
  10.     xTime = DateAdd("N", 30 * xTime, 0)
  11.     Debug.Print "下一個30分整", Time, xTime
  12.     xTime = Int(Application.Text(Time, "[h]") / 3) + 1
  13.     xTime = DateAdd("h", 3 * xTime, 0)
  14.     Debug.Print "下一個3小時整", Time, xTime
  15. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 12# no3-taco

INT 的用途是找出,分鐘數被3整除的整數
  1. Option Explicit
  2. Sub Ex()
  3.     Dim xTime As Variant, nTime As Date
  4.     Application.VBE.Windows("即時運算").Visible = True
  5.         nTime = Time
  6.     xTime = Int(Application.Text(nTime, "[m]") / 3) + 1
  7.     xTime = DateAdd("N", 3 * xTime, 0)
  8.     Debug.Print nTime, "第一個3分整", xTime; "", vbLf
  9.     nTime = xTime
  10.     xTime = Int(Application.Text(xTime, "[m]") / 3) + 1
  11.     xTime = DateAdd("N", 3 * xTime, 0)
  12.     Debug.Print nTime, "再下個3分整", xTime, vbLf
  13.     Debug.Print "你是要間隔3分鐘後的時間如下"
  14.     nTime = Time + #12:03:00 AM#
  15.     Debug.Print Time, "間隔3分鐘後", nTime
  16.    
  17. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 14# Jason80Lo
    5樓的程式碼有防止搜尋到前次搜尋過TXT檔的判斷式.
  1.   xFile = Dir(xPath & "\*.txt")          '搜尋附檔名
  2. Do While xFile <> ""                   '找到
  3.     Set Rng(2) = Rng(1).Find(xFile, LookAT:=xlWhole) '比對第一列中的 txt檔
  4.      '***************************************************
  5.      If Rng(2) Is Nothing Then                        '第一列中比對沒有這txt檔
  6.      '************這判斷式不是嗎***
  7.           i = 1
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 17# Jason80Lo

試試看
  1. Option Explicit
  2. Private Sub EX()
  3.     Dim xPath As String, Rng(1 To 2) As Range, xFile As String, a As Variant, r As String
  4.     Dim i As Boolean, f As Integer, xString, xMatch As Variant
  5.     Dim S As Worksheet, AR(), x_Row As Integer
  6.    
  7.     If Join(AR, "") = "" Then ReDim AR(0)   '為空陣列,陣列宣告為一元素
  8.     If IsArray([xFile_Add]) Then AR = [xFile_Add]  '當活頁簿的名稱是陣列
  9.     ' [xFile_Add] -> [這活頁簿的名稱或函數]
  10.     Set S = ActiveWorkbook.ActiveSheet
  11.     Set Rng(1) = S.Rows(1)                          '使用中活頁簿,這工作表的第一列
  12.     xPath = "C:\Users\j\Desktop\新增資料夾 (4)\"    'txt 檔案的目錄
  13.     xFile = Dir(xPath & "*.txt")                    '搜尋附檔名
  14.     Do While xFile <> ""                            '找到
  15.         xMatch = Application.Match(xFile, AR, 0)    '陣列中搜尋
  16.         If IsError(xMatch) Then                     '陣列中搜尋沒有這txt檔
  17.             If Join(AR, "") = "" Then
  18.                 AR(0) = xFile                       '陣列第一元素=xFile
  19.             Else
  20.                 ReDim Preserve AR(0 To UBound(AR) + 1) '陣列上限元素+1
  21.                 AR(UBound(AR)) = xFile
  22.             End If
  23.             Set Rng(2) = Rng(1).Cells(Application.CountA(Rng(1)) + 1) '依序在第一列中
  24.             i = True
  25.             Rng(2).Cells = xFile                    '檔名寫入儲存格中
  26.             f = FreeFile
  27.             Open xPath & xFile For Input Access Read As #1  '開啟文字檔
  28.                 Do Until EOF(1)                     '執行迴圈直到檔尾為止。
  29.                     Line Input #1, xString          '將資料讀入變數中。
  30.                     a = Split(xString, Space(1))    '該檔案以,為分隔符號
  31.                     'Split 的型態Variant
  32.                     If i Then
  33.                         Rng(2).Cells(2, 1).Resize(UBound(a) + 1) = Application.Transpose(a)
  34.                         i = 0
  35.                     Else
  36.                         With Rng(2).End(xlDown).Offset(1)
  37.                             .Resize(UBound(a) + 1) = Application.Transpose(a)
  38.                         End With
  39.                     End If
  40.                 Loop
  41.                 Close #f    ' 關閉檔案。
  42.         End If
  43.         xFile = Dir         '查下一個 txt檔
  44.     Loop
  45.     If Join(AR, "") <> "" Then ThisWorkbook.Names.Add "xFile_Add", AR    '這活頁簿的名稱 內容為這陣列,
  46. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 口說一句好話,如口出蓮花;口說一句壞話如口吐毒蛇。
返回列表 上一主題