Giúp đỡ về đọc các file text từ thư mục input sau đó ghi dữ liệu ra file excel

Liên hệ QC
Q

quydouct

Thành viên mới
Tham gia
12/6/12
Bài viết
7
Được thích
2
Chào các bạn,
Mình mới tập viết code VBA và đang có vấn đề như sau mong các bạn giúp đỡ.
Mình cần viết code VBA để đọc các file trong 1 thư mục input nội dung các file đó có dạng giống nhau như thế này :
<%
abc dfe ghi = "xxxxxxx"
123 fgv poi = "yyyyyy"
.....................................
%>
Bài toán đặt ra là đọc các file này và ghi ra 1 file excel có các sheet là tên của các file trong thư mục input. Trong sheet này có 2 trường là Name ( phần trước dấu "=" trong file input) và trường Value ( sau dấu "=" ).
Thanks
 

File đính kèm

  • output.xlsx
    8.7 KB · Đọc: 30
  • file1.txt
    57 bytes · Đọc: 43
Lần chỉnh sửa cuối:
quydouct đã viết:
Chào các bạn,
Mình mới tập viết code VBA và đang có vấn đề như sau mong các bạn giúp đỡ.
Mình cần viết code VBA để đọc các file trong 1 thư mục input nội dung các file đó có dạng giống nhau như thế này :
<%
abc dfe ghi = "xxxxxxx"
123 fgv poi = "yyyyyy"
.....................................
%>
Bài toán đặt ra là đọc các file này và ghi ra 1 file excel có các sheet là tên của các file trong thư mục input. Trong sheet này có 2 trường là Name ( phần trước dấu "=" trong file input) và trường Value ( sau dấu "=" ).
Thanks
Nhấp chuột vào đây để mở rộng...
Thì bạn cũng phải đưa lên 1 vài file txt + file Excel làm ví dụ minh họa chứ
 
Mình đã attact 2 file mẫu lên. Mình xin giải thích rõ hơn cho 2 file đó giả sử thư mục input có 3 file là file1, file2, file3 với nội dung tương tự như file txt mình đưa lên, khi đó file result sẽ có 3 sheet là file1, file2, file3 và trên mỗi sheets sẽ có các giá trị được đọc từ file txt ghi vào.

ndu96081631 đã viết:
Thì bạn cũng phải đưa lên 1 vài file txt + file Excel làm ví dụ minh họa chứ
Nhấp chuột vào đây để mở rộng...
 
quydouct đã viết:
Mình đã attact 2 file mẫu lên. Mình xin giải thích rõ hơn cho 2 file đó giả sử thư mục input có 3 file là file1, file2, file3 với nội dung tương tự như file txt mình đưa lên, khi đó file result sẽ có 3 sheet là file1, file2, file3 và trên mỗi sheets sẽ có các giá trị được đọc từ file txt ghi vào.
Nhấp chuột vào đây để mở rộng...

Món này làm chẳng khó khăn gì, chỉ là hơi.. cực thân 1 chút
Tôi đề xuất code như sau:
1> Các hàm hổ trợ:
PHP: 
Function GetTxtFileName(ByVal fldName As String)
  Dim Arr(), fle As Object, n As Long
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    With .GetFolder(fldName)
      For Each fle In .Files
        If fle.Type = "Text Document" Then
          ReDim Preserve Arr(n)
          Arr(n) = fle.Path
          n = n + 1
        End If
      Next
    End With
  End With
  If IsArray(Arr) Then GetTxtFileName = Arr
End Function
PHP: 
Function GetValFromTxt(ByVal txtFile As String)
  Dim tmpArr, Arr(), n As Long, i As Long, tmp As String, Item
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(txtFile) Then
      With .OpenTextFile(txtFile, 1)
        tmpArr = Split(.ReadAll, vbCrLf)
        If IsArray(tmpArr) Then
          ReDim Arr(1 To UBound(tmpArr) + 2, 1 To 3)
          Arr(1, 1) = "No"
          Arr(1, 2) = "Name"
          Arr(1, 3) = "Value"
          n = 1
          For i = 0 To UBound(tmpArr)
            tmp = Trim(CStr(tmpArr(i)))
            If Len(tmp) Then
              If InStr(1, tmp, "=") Then
                Item = Split(tmp, "=")
                n = n + 1
                Arr(n, 1) = n - 1
                Arr(n, 2) = Item(0)
                Arr(n, 3) = Item(1)
              End If
            End If
          Next
          If IsArray(Arr) Then GetValFromTxt = Arr
        End If
        .Close
      End With
    End If
  End With
End Function
PHP: 
Function SheetExists(ByVal wksName As String) As Boolean
  On Error Resume Next
  SheetExists = Not ThisWorkbook.Sheets(wksName) Is Nothing
End Function
2> Code chính:
PHP: 
Sub Main()
  Dim fleName As String, txtFile As String, fldName As String, wksName As String, tmp As String
  Dim n As Long, i As Long, Arr, aFile
  On Error Resume Next
  With CreateObject("Shell.Application")
    fldName = .BrowseForFolder(0, "", 1).Self.Path
  End With
  If Len(fldName) Then
    aFile = GetTxtFileName(fldName)
    If IsArray(aFile) Then
      For i = 0 To UBound(aFile)
        txtFile = CStr(aFile(i))
        Arr = GetValFromTxt(txtFile)
        With CreateObject("Scripting.FileSystemObject")
          fleName = .GetFile(txtFile).Name
          wksName = Left(fleName, Len(fleName) - 4)
        End With
        If Len(wksName) Then
          If Not SheetExists(wksName) Then
            ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = wksName
          End If
          With ThisWorkbook.Sheets(wksName)
            .UsedRange.ClearContents
            .Range("A1").Resize(UBound(Arr, 1), 3) = Arr
          End With
        End If
      Next
    End If
  End If
End Sub
Viết sơ qua thế thôi, không biết còn lỗi nào ngoài ý muốn không. Bạn tải file về chạy code và tự kiểm tra nhé
Có vấn đề gì ta sẽ bàn tiếp
 

File đính kèm

  • output.rar
    20.3 KB · Đọc: 135
Cảm ơn bạn, mình đã chạy thử thì bị lỗi chỗ kiểm tra điều kiện file txt
If fle.Type = "Text Document" Then ( Đoạn này chạy có file txt trong thư mục nhưng nó k nhận ra )
chỗ này mình sửa lại thành
If Right(fle, 3) = "txt" Then
thì chạy đc rồi :)

 
quydouct đã viết:
Cảm ơn bạn, mình đã chạy thử thì bị lỗi chỗ kiểm tra điều kiện file txt
If fle.Type = "Text Document" Then ( Đoạn này chạy có file txt trong thư mục nhưng nó k nhận ra )
chỗ này mình sửa lại thành
If Right(fle, 3) = "txt"Then
thì chạy đc rồi :)
Nhấp chuột vào đây để mở rộng...

Bởi vậy mới nói bạn kiểm tra! (dù tôi đã test trên máy tôi và chạy bình thường)
Cũng có thể do phiên bản Office khác nhau nên lệnh cũng có khác nhau chăng? (tôi dùng Office 2010)
Ai mà biết được
Ẹc... Ẹc...
--------------
Ngoài ra, nếu sửa như bạn thì phải sửa cho "chắc" 1 chút
Thay
If Right(fle, 3) = "txt" Then
Thành:
If UCase(Right(fle.Name , 4)) = ".TXT" Then
Lý dọ:
- Có những file text mà đuôi của nó là TXT chứ không phải txt
- Có dạng file không có phần mở rộng và tên nó có dạng filetxt thì sao? (lấy right 3 ký tự cũng ra txt nhưng nó không phải file text)
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Bởi vậy mới nói bạn kiểm tra! (dù tôi đã test trên máy tôi và chạy bình thường)
Cũng có thể do phiên bản Office khác nhau nên lệnh cũng có khác nhau chăng? (tôi dùng Office 2010)
Ai mà biết được
Ẹc... Ẹc...
--------------
Ngoài ra, nếu sửa như bạn thì phải sửa cho "chắc" 1 chút
Thay
If Right(fle, 3) = "txt" Then
Thành:
If UCase(Right(fle.Name , 4)) = ".TXT" Then
Lý dọ:
- Có những file text mà đuôi của nó là TXT chứ không phải txt
- Có dạng file không có phần mở rộng và tên nó có dạng filetxt thì sao? (lấy right 3 ký tự cũng ra txt nhưng nó không phải file text)
Nhấp chuột vào đây để mở rộng...

Đúng là sửa như bạn sẽ "chắc" hơn thật. Mình mới tập code vba được vài ngày nên chưa có kinh nghiệm :D
Ngoài ra nhờ bạn chút, mình thấy ở đây có vấn đề 1 chút nếu như cái file txt nó line nào đó có nhiều hơn 1 dấu "=" dạng như thế này thì sẽ bị lỗi ví dụ như line:
bien_x = "value_x= abc"
nó sẽ lấy
name = bien_x ,
value = "value_x
mà bỏ đi mất phần: = abc"
Mình muốn chỉ cắt theo dấu "=" đầu tiên của line đó còn tất cả phần sau dấu "=" đầu tiên đó đều coi là value hết thì sửa thế nào?
 
quydouct đã viết:
Đúng là sửa như bạn sẽ "chắc" hơn thật. Mình mới tập code vba được vài ngày nên chưa có kinh nghiệm :D
Ngoài ra nhờ bạn chút, mình thấy ở đây có vấn đề 1 chút nếu như cái file txt nó line nào đó có nhiều hơn 1 dấu "=" dạng như thế này thì sẽ bị lỗi ví dụ như line:
bien_x = "value_x= abc"
nó sẽ lấy
name = bien_x ,
value = "value_x
mà bỏ đi mất phần: = abc"
Mình muốn chỉ cắt theo dấu "=" đầu tiên của line đó còn tất cả phần sau dấu "=" đầu tiên đó đều coi là value hết thì sửa thế nào?
Nhấp chuột vào đây để mở rộng...
Trong hàm GetValFromTxt, hãy sửa đoạn:
Arr(n, 3) = Item(1)
Thành:
Arr(n, 3) = Mid(tmp, InStr(1, tmp, "=") + 1, Len(tmp))
-----------------
Ngoài lề chút. Bạn nói
quydouct đã viết:
Mình mới tập code vba được vài ngày nên chưa có kinh nghiệm
Nhấp chuột vào đây để mở rộng...
Đúng là cũng... khó tin thật đấy! Vì nhìn cả "rừng" code thế kia mà bạn vẫn biết cần phải sửa lại chổ nào mới chạy được
Khâm phục!
 
Lần chỉnh sửa cuối:
ndu96081631 đã viết:
Trong hàm GetValFromTxt, hãy sửa đoạn:
Arr(n, 3) = Item(1)
Thành:
Arr(n, 3) = Mid(tmp, InStr(1, tmp, "=") + 1, Len(tmp))
-----------------
Ngoài lề chút. Bạn nói
Đúng là cũng... khó tin thật đấy! Vì nhìn cả "rừng" code thế kia mà bạn vẫn biết cần phải sửa lại chổ nào mới chạy được
Khâm phục!
Nhấp chuột vào đây để mở rộng...

Mình sửa lại theo bạn đã chạy OK rồi.
Chính xác thì mình mới tập code VBA từ hôm thứ 3 vừa rồi, nhưng trước kia có học qua C# thấy nó có nhiều cái tương đồng nên cũng nhanh. Còn phát hiện ra chỗ cần sửa thì đặt vài cái Msgbox cho in giá trị rồi chạy Debug là biết nó sai ở đâu thôi mà :D
Cảm ơn NDU rất nhiều chắc sẽ có nhiều cái cần bạn giúp đỡ :)
 
Mình muốn sau khi lấy dữ liệu sẽ ghi ra 1 file excel khác và xoá đi các Sheet có sẵn (sheet1,2,3) Nên đã sửa lại code như bên dưới nhưng khi xoá Sheet đi nó vẫn còn Sheet2 không bị xoá k biết bị lỗi thế nào?


Sub Main()
Dim fleName As String, txtFile As String, fldName As String, wksName As String, tmp As String
Dim n As Long, i As Long, Arr, aFile
On Error Resume Next
With CreateObject("Shell.Application")
fldName = .BrowseForFolder(0, "", 1).Self.Path
End With
If Len(fldName) Then
aFile = GetTxtFileName(fldName)
If IsArray(aFile) Then
For i = 0 To UBound(aFile)
txtFile = CStr(aFile(i))
Arr = GetValFromTxt(txtFile)
With CreateObject("Scripting.FileSystemObject")
fleName = .GetFile(txtFile).Name
wksName = Left(fleName, Len(fleName) - 4)
End With
If Len(wksName) Then
Workbooks.Add
Workbooks.Item(2).Activate
If Not SheetExists(wksName) Then
ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = wksName
End If
With ActiveWorkbook.Sheets(wksName)
.UsedRange.ClearContents
.Range("A1").Resize(UBound(Arr, 1), 3) = Arr
End With
End If
Application.DisplayAlerts = False
Sheets(1).Delete
Sheets(2).Delete
Sheets(3).Delete
ActiveWorkbook.SaveAs Filename:="C:\ResourceList.xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Next
End If
End If
End Sub
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
quydouct đã viết:
Mình muốn sau khi lấy dữ liệu sẽ ghi ra 1 file excel khác và xoá đi các Sheet có sẵn (sheet1,2,3) Nên đã sửa lại code như bên dưới nhưng khi xoá Sheet đi nó vẫn còn Sheet2 không bị xoá k biết bị lỗi thế nào?
Nhấp chuột vào đây để mở rộng...
Bạn không cần phải Add Workbook, cũng không cần phải xóa các sheet 1, 2, 3 làm gì cho mất công!
Cách của tôi là:
- Cứ chạy code bình thường
- Khi đã tạo ra được các sheet mới, Move or copy to các sheet ấy ra 1 Workbook mới rồi save nó là được rồi
Code như sau:
Mã: 
Sub Main()
  Dim fleName As String, txtFile As String, fldName As String, wksName As String, tmp As String
  Dim n As Long, i As Long, Arr, aFile, [COLOR=#ff0000][B]aWks(), lCount As Long[/B][/COLOR]
  On Error Resume Next
  With CreateObject("Shell.Application")
    fldName = .BrowseForFolder(0, "", 1).Self.Path
  End With
  If Len(fldName) Then
    aFile = GetTxtFileName(fldName)
    If IsArray(aFile) Then
      For i = LBound(aFile) To UBound(aFile)
        txtFile = CStr(aFile(i))
        Arr = GetValFromTxt(txtFile)
        If IsArray(Arr) Then
          With CreateObject("Scripting.FileSystemObject")
            fleName = .GetFile(txtFile).Name
            wksName = Left(fleName, Len(fleName) - 4)
           [COLOR=#ff0000][B] lCount = lCount + 1
            ReDim Preserve aWks(1 To lCount)
            aWks(lCount) = wksName[/B][/COLOR]
          End With
          If Not SheetExists(wksName) Then
            ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = wksName
          End If
          With ThisWorkbook.Sheets(wksName)
            .UsedRange.ClearContents
            .Range("A1").Resize(UBound(Arr, 1), 3) = Arr
          End With
        End If
      Next
    [COLOR=#ff0000][B]  If lCount Then
        ThisWorkbook.Sheets(aWks).Move
        With ActiveWorkbook
          .SaveAs "C:\ResourceList", xlNormal
          .Close
        End With
      End If[/B][/COLOR]
    End If
  End If
End Sub
Những dòng code màu đỏ là cái thêm vào đấy (các chổ khác để nguyên)
-------------------
Ngoài ra cũng xin sửa lại 2 đoạn code sau cho "chắc" hơn:
PHP: 
Function GetTxtFileName(ByVal fldName As String)
  Dim Arr(), fle As Object, n As Long
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    With .GetFolder(fldName)
      For Each fle In .Files
        If UCase(Right(fle.Name, 4)) = ".TXT" Then
          n = n + 1
          ReDim Preserve Arr(1 To n)
          Arr(n) = fle.Path
        End If
      Next
    End With
  End With
  If n Then GetTxtFileName = Arr
End Function
PHP: 
Function GetValFromTxt(ByVal txtFile As String)
  Dim tmpArr, Arr(), n As Long, i As Long, tmp As String, Item
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(txtFile) Then
      With .OpenTextFile(txtFile, 1)
        tmpArr = Split(.ReadAll, vbCrLf)
        If IsArray(tmpArr) Then
          ReDim Arr(1 To UBound(tmpArr) + 2, 1 To 3)
          Arr(1, 1) = "No"
          Arr(1, 2) = "Name"
          Arr(1, 3) = "Value"
          n = 1
          For i = 0 To UBound(tmpArr)
            tmp = Trim(CStr(tmpArr(i)))
            If Len(tmp) Then
              If InStr(1, tmp, "=") Then
                Item = Split(tmp, "=")
                n = n + 1
                Arr(n, 1) = n - 1
                Arr(n, 2) = Item(0)
                Arr(n, 3) = Mid(tmp, InStr(1, tmp, "=") + 1, Len(tmp))
              End If
            End If
          Next
          If n > 1 Then GetValFromTxt = Arr
        End If
        .Close
      End With
    End If
  End With
End Function
 
Lần chỉnh sửa cuối:
Mọi người ơi cho mình hỏi Hàng ngày mình nhận văn bản sau đó cuối tháng phải thông kê và phân loại. Mình mới tạo song Form nhập liệu và ghi dữ liệu như theo hướng ở trên mạng, vấn đề của mình bang biểu thông kê là có sẵn (tức hàng và cột là cố định không phải thêm bớt gì cả) khi nhập và ghi dữ liệu thì dữ liệu sẽ tự động ghi vào các ô cố định đó. Đến cuối tháng hoặc cuối kỳ thống kê sẽ ra số liệu trong tháng đó đã nhận được tổng bao văn bản và những loại văn bản gì trong từng lĩnh vực. Ví dụ:
- ngày 1.1.2017 mình nhận được 5 văn bản trong đó - 3 văn bản về tranh chấp tài sản, 2 văn bản thuộc lĩnh vực về tranh chấp đất đai, - Có 4 văn bản gửi cho mình đúng hạn theo luật định và 1 văn bản gửi quá hạn.
- 5.1.2017 mình nhận được 6 văn bản trong đó - 4 văn bản về tranh chấp tài sản, 2 văn bản thuộc lĩnh vực về tranh chấp đất đai,- Có 3 văn bản gửi cho mình đúng hạn theo luật định và 2 văn bản gửi quá hạn.
Đến cuối tháng 1 thì số liệu thống kê (tại sheet Bieu_13 cột F và tại các hàng 11, 13,14 sẽ có số liệu lần lượt là: 11 văn bản; 7 về tranh chấp tài sản; 4 về tranh chấp đất đai; 3 văn bản quá hạn. Mình có gửi file đính kèm, nhờ các bạn giúp đỡ.
Thanks nhiều
 

File đính kèm

  • bieu mau dan su 11_7.xlsm
    253.2 KB · Đọc: 7
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

P
HÀM SUBTOTAL BỊ #VALUE
Trả lời
2
Đọc
32
phantuancauvan
P
phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
2
Trả lời
28
Đọc
386
VetMini
V
tby211
Lỗi 1004 vba khi tách file trắc nghiệm sang excel
Trả lời
0
Đọc
19
tby211
tby211
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
6
Đọc
143
NguyenthiH
NguyenthiH
test1986
  • Question
HELP! Sử dụng combobox để cập nhật dữ liệu trong file Excel
Trả lời
17
Đọc
508
ngochienbmt
N
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom