標題:
[發問]
請問VBA 針對文件檔如何取出指定條件並寫入EXCEL內?
[打印本頁]
作者:
starry1314
時間:
2021-3-19 18:31
標題:
請問VBA 針對文件檔如何取出指定條件並寫入EXCEL內?
我有一份固定產出的文件檔
格式如下,檔案已附上
(種類會有數十種,需取其中一種指定種類並個別統計項目數量)
有找到兩份有點類似的程式碼但改不好
Sub ReadfiletoExcel()
Dim s As Worksheet
Dim f As Integer
Dim r As String
Dim i As Integer
Dim j As Integer
Dim a() As String
i = 2 '從第i列開始寫入檔案資料,i可自訂依自己需要,在這範例設i為5
Set s = ActiveSheet
f = FreeFile
Open s.Range("A1").Value For Input As #f
Do While Not EOF(f)
Line Input #f, r
a = Split(r, ",") '該檔案以,為分隔符號
For j = 0 To UBound(a)
s.Cells(i, j + 1).Value = a(j) '讀取資料依序存入第i列的第1個到j個欄位
Next j
i = i + 1
Loop
Close #f
MsgBox "讀取檔案資料ok"
End Sub
複製代碼
Function PutRowData(strData As String, strSheets As String, strCol As String)
'塞資料到指定欄位,並放到該欄的最後空白列
'資料串由Tab字元自動切開,放置不同欄的資料到不同欄位裡
'
'strData 資料串
'strSheets 指定工作表
'strCol 指定欄位(英文字)
Dim objDes As Object
Set objDes = Sheets(strSheets)
iNewRow = objDes.Range(strCol & "65535").End(xlUp).Row + 1
If iNewRow = 2 Then
objDes.Columns("A:B").ColumnWidth = 23
objDes.Columns("C").ColumnWidth = 8
objDes.Columns("D").ColumnWidth = 29
objDes.Columns("E:P").ColumnWidth = 8
objDes.Columns("Q").ColumnWidth = 29
'objDes.Columns("A:Q").EntireColumn.AutoFit
Title = "種類"
tmpTitle = Split(Title, ",")
For intI = 0 To UBound(tmpTitle)
intC = intI + 1
objDes.Range(strCol & "2").Offset(0, intC) = tmpTitle(intI)
Next
iNewRow = iNewRow + 3
End If
tmp = Split(strData, ",")
For i = 0 To UBound(tmp)
If i = 16 Then '第16個陣列值取26個字元 = 00 00 00 00 00 00 00 00 00 00
objDes.Range(strCol & iNewRow).Offset(0, i) = Mid(tmp(i), 1, 29)
Else
objDes.Range(strCol & iNewRow).Offset(0, i) = tmp(i)
End If
Next
End Function
Public Function ReadATextFileToEOF(strKeyWord As String, Optional strPath As String, Optional strFileType As String = "*.*")
'讓user選擇純文字檔,打開檔案後,逐行搜尋,找到關鍵字,就把資料放到現在的工作表內
'變數說明
'strKeyWord 關鍵字
'strPath 預設開啟路徑
'strFileType 檔案類型 *.txt 或其他
'
Dim intFile As Integer
Dim strFile As String
Dim strIn As String
Dim bnFound As Boolean
booFound = False
strOut = vbNullString
intFile = FreeFile()
Range("A1:IV65536").ClearContents '清除表格資料
Dim fd As FileDialog, FileName As String, FileFolder As String
Set fd = Application.FileDialog(3)
With fd
.Filters.Clear
.Filters.Add "All Text Files", "*.txt"
.AllowMultiSelect = False
If .Show = -1 Then
strFile = .SelectedItems(1) '#1
Else
End
End If
End With
MsgBox "您的檔案路徑如下" & vbCrLf & strFile
'strFile = "d:\1231.txt"
'使用Open方式開啟純文字檔(不支援UTF8)
Open strFile For Input As #intFile
i = 0
Do While Not EOF(intFile)
Line Input #intFile, strIn '依照「行」來讀取資料
i = i + 1
j = InStr(strIn, strKeyWord) '使用InStr字串搜尋,有找到關鍵字,就帶入到工作表中
If j > 0 Then
'Call PutRowData("「" & strKeyWord & "」在第 " & i & "行,第 " & j & "字元," & Mid(strIn, j, 170), ActiveSheet.Name, "B")
Call PutRowData(Mid(strIn, j, 170), ActiveSheet.Name, "A")
'MsgBox (strIn)
bnFound = True
End If
Loop
Close #intFile
If bnFound = False Then
MsgBox "找不到關鍵字!"
End If
End Function
Sub 按鈕2_Click()
Call ReadATextFileToEOF("種類:肉品", "", "*.txt")
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/)