Board logo

標題: [發問] 請問VBA 針對文件檔如何取出指定條件並寫入EXCEL內? [打印本頁]

作者: starry1314    時間: 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 指定欄位(英文字)

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

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

  34. End Function


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

  42. Dim intFile As Integer
  43. Dim strFile As String
  44. Dim strIn As String
  45. Dim bnFound As Boolean

  46. booFound = False
  47. strOut = vbNullString
  48. intFile = FreeFile()

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

  50. Dim fd As FileDialog, FileName As String, FileFolder As String
  51. Set fd = Application.FileDialog(3)
  52. With fd
  53. .Filters.Clear
  54. .Filters.Add "All Text Files", "*.txt"
  55. .AllowMultiSelect = False
  56.     If .Show = -1 Then
  57.         strFile = .SelectedItems(1)  '#1
  58.     Else
  59.         End
  60.     End If
  61. End With
  62. MsgBox "您的檔案路徑如下" & vbCrLf & strFile

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

  78. Close #intFile

  79. If bnFound = False Then
  80.     MsgBox "找不到關鍵字!"
  81. End If
  82. End Function

  83. Sub 按鈕2_Click()
  84. Call ReadATextFileToEOF("種類:肉品", "", "*.txt")
  85. End Sub
複製代碼
種類: 肉品
碎豬肉
--------
產品規格: 5/20
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
種類: 再製品
貢丸
--------
產品規格: 8/20
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
種類: 魚類
鮭魚
--------
產品規格: 8/20
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
種類: 肉品
豬肉片
--------
產品規格: 80/120
--------
XXXXXXXXX-備註
--------
XXXXXXXXX-注意事項
原始檔案:[attach]33143[/attach]
呈現結果:[attach]33144[/attach]




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)