返回列表 上一主題 發帖

[發問] 請問VBA 針對文件檔如何取出指定條件並寫入EXCEL內?

starry1314
　暱稱: 豪

高中生Rank: 3Rank: 3

帖子
471 
主題
121 
精華
0 
積分
579 
點名
0  
作業系統
WIN10 
軟體版本
OFFICE2019 
閱讀權限
50 
性別
男 
註冊時間
2015-4-16 
最後登錄
2023-1-17 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2021-3-19 18:31 | 只看該作者

[發問] 請問VBA 針對文件檔如何取出指定條件並寫入EXCEL內?

我有一份固定產出的文件檔
格式如下,檔案已附上
(種類會有數十種,需取其中一種指定種類並個別統計項目數量)
有找到兩份有點類似的程式碼但改不好
  1. Sub ReadfiletoExcel()
  2. Dim s As Worksheet
  3. Dim f As Integer
  4. Dim r As String
  5. Dim i As Integer
  6. Dim j As Integer
  7. Dim a() As String
  8. i = 2 '從第i列開始寫入檔案資料,i可自訂依自己需要,在這範例設i為5
  9. Set s = ActiveSheet
  10. f = FreeFile
  11. Open s.Range("A1").Value For Input As #f
  12. Do While Not EOF(f)
  13. Line Input #f, r
  14. a = Split(r, ",") '該檔案以,為分隔符號
  15. For j = 0 To UBound(a)
  16. s.Cells(i, j + 1).Value = a(j) '讀取資料依序存入第i列的第1個到j個欄位
  17. Next j
  18. i = i + 1
  19. Loop
  20. Close #f
  21. MsgBox "讀取檔案資料ok"
  22. End Sub
複製代碼
  1. Function PutRowData(strData As String, strSheets As String, strCol As String)
  2. '塞資料到指定欄位，並放到該欄的最後空白列
  3. '資料串由Tab字元自動切開，放置不同欄的資料到不同欄位裡
  4. '
  5. 'strData 資料串
  6. 'strSheets 指定工作表
  7. 'strCol 指定欄位（英文字）

  9.     Dim objDes As Object
  10.     Set objDes = Sheets(strSheets)

  12.     iNewRow = objDes.Range(strCol & "65535").End(xlUp).Row + 1
  13.     If iNewRow = 2 Then
  14.         objDes.Columns("A:B").ColumnWidth = 23
  15.         objDes.Columns("C").ColumnWidth = 8
  16.         objDes.Columns("D").ColumnWidth = 29
  17.         objDes.Columns("E:P").ColumnWidth = 8
  18.         objDes.Columns("Q").ColumnWidth = 29
  19.         'objDes.Columns("A:Q").EntireColumn.AutoFit
  20.         Title = "種類"
  21.         tmpTitle = Split(Title, ",")
  22.             For intI = 0 To UBound(tmpTitle)
  23.                 intC = intI + 1
  24.                 objDes.Range(strCol & "2").Offset(0, intC) = tmpTitle(intI)
  25.             Next
  26.         iNewRow = iNewRow + 3
  27.     End If
  28.     tmp = Split(strData, ",")
  29.     For i = 0 To UBound(tmp)
  30.         If i = 16 Then '第16個陣列值取26個字元 = 00 00 00 00 00 00 00 00 00 00
  31.         objDes.Range(strCol & iNewRow).Offset(0, i) = Mid(tmp(i), 1, 29)
  32.         Else
  33.         objDes.Range(strCol & iNewRow).Offset(0, i) = tmp(i)
  34.         End If
  35.     Next

  37. End Function


  40. Public Function ReadATextFileToEOF(strKeyWord As String, Optional strPath As String, Optional strFileType As String = "*.*")
  41. '讓user選擇純文字檔，打開檔案後，逐行搜尋，找到關鍵字，就把資料放到現在的工作表內
  42. '變數說明
  43. 'strKeyWord 關鍵字
  44. 'strPath 預設開啟路徑
  45. 'strFileType 檔案類型 *.txt 或其他
  46. '

  48. Dim intFile As Integer
  49. Dim strFile As String
  50. Dim strIn As String
  51. Dim bnFound As Boolean

  53. booFound = False
  54. strOut = vbNullString
  55. intFile = FreeFile()

  57. Range("A1:IV65536").ClearContents '清除表格資料

  59. Dim fd As FileDialog, FileName As String, FileFolder As String
  60. Set fd = Application.FileDialog(3)
  61. With fd
  62. .Filters.Clear
  63. .Filters.Add "All Text Files", "*.txt"
  64. .AllowMultiSelect = False
  65.     If .Show = -1 Then
  66.         strFile = .SelectedItems(1)  '#1
  67.     Else
  68.         End
  69.     End If
  70. End With
  71. MsgBox "您的檔案路徑如下" & vbCrLf & strFile

  73. 'strFile = "d:\1231.txt"
  74. '使用Open方式開啟純文字檔(不支援UTF8)
  75. Open strFile For Input As #intFile
  76. i = 0
  77. Do While Not EOF(intFile)
  78.     Line Input #intFile, strIn '依照「行」來讀取資料
  79.     i = i + 1
  80.     j = InStr(strIn, strKeyWord) '使用InStr字串搜尋，有找到關鍵字，就帶入到工作表中
  81.     If j > 0 Then
  82.           'Call PutRowData("「" & strKeyWord & "」在第 " & i & "行，第 " & j & "字元," & Mid(strIn, j, 170), ActiveSheet.Name, "B")
  83.            Call PutRowData(Mid(strIn, j, 170), ActiveSheet.Name, "A")
  84.           'MsgBox (strIn)
  85.         bnFound = True
  86.     End If
  87. Loop

  89. Close #intFile

  91. If bnFound = False Then
  92.     MsgBox "找不到關鍵字！"
  93. End If
  94. End Function

  96. Sub 按鈕2_Click()
  97. Call ReadATextFileToEOF("種類:肉品", "", "*.txt")
  98. End Sub
複製代碼
種類: 肉品
碎豬肉
--------
產品規格: 5/20
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
種類: 再製品
貢丸
--------
產品規格: 8/20
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
種類: 魚類
鮭魚
--------
產品規格: 8/20
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
種類: 肉品
豬肉片
--------
產品規格: 80/120
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
原始檔案: CH.rar (210 Bytes)
呈現結果: 呈現結果.rar (6.65 KB)
收藏 分享

        靜思自在 : 世上有兩件事不能等：一、孝順 二、行善。
返回列表 上一主題