Cảm ơn Bạn HieuCD
Bạn cho mình hỏi 2 vấn đề liên quan trong file nữa nha,
- Ở câu code:
ProName = Split(sArr(3, 3), ".")(0)
Res(1, 2) = ProName & "-RS1"
ProName = 10203040 là OK rồi và mình muốn lấy RS là chữ ở trong mục Line name (Mình muốn nó tự động lấy luôn, không phải nhập bằng tay vì trong file text dữ liệu chỗ Linename có thể thay đổi, không cố đinh)
Bạn xem có hiệu chỉnh Code được không
- Còn một vấn đề nữa là file .txt thì có rất nhiều tên,
nếu mình muốn để 2 file vào một folder, mở excel lên và chạy code mà không cần sửa tên trùng nhau giữa {10203040.txt và FilesToOpen = ThisWorkbook.Path & "\10203040-RS.txt" } thì có được không?
Cảm ơn Bạn.
Đính kèm Code:
Sub Main()
Dim sArr As Variant, dArr As Variant, Res As Variant, S As Variant
Dim ProName As String, LineName As String, tmp As String, FilesToOpen As String
Dim i As Long, fR As Long, nR As Long, k As Long, ik As Long, j As Byte
FilesToOpen = ThisWorkbook.Path & "\10203040-RS.txt"
sArr = ImportTextToExcel(FilesToOpen)
dArr = Range("B7:k8").Value
ReDim Res(1 To UBound(sArr), 1 To 7)
For j = 1 To 6
Res(1, j) = dArr(1, j): Res(2, j) = dArr(2, j)
Next j
Res(2, 7) = dArr(2, 7)
ProName = Split(sArr(3, 3), ".")(0)
Res(1, 2) = ProName & "-RS1"
Res(1, 1) = "Program Name"
Res(1, 6) = "No. of components"
Res(1, 4) = "Simulated time (s)"
Res(2, 1) = "F. Position N."
Res(2, 2) = "Component Name"
Res(2, 3) = "Placement ID"
Res(2, 4) = "Description"
Res(2, 5) = "Feeder Type"
Res(2, 6) = "Component pitch"
Res(2, 7) = "Qty."
With CreateObject("scripting.dictionary")
For i = 1 To UBound(sArr)
If Left(sArr(i, 1), 2) = "F-" Then fR = i: Exit For
Next i
k = 2
For i = fR To UBound(sArr)
k = k + 1
If Left(sArr(i, 1), 2) = "F-" Then
Res(k, 1) = sArr(i, 1)
Res(k, 5) = sArr(i, 4)
Res(k, 6) = sArr(i, 5)
Key = sArr(i, 2)
S = Split(Key, " ")
Res(k, 2) = S(1): Res(k, 4) = S(0)
.Item(Key) = k
Else
For j = 1 To 6
Res(k, j) = dArr(1, j)
Next j
Res(k, 1) = "Program Name"
Res(k, 2) = ProName & "-RS2"
nR = k
Res(k, 6) = "No. of components"
Res(k, 4) = "Simulated time (s)"
End If
Next i
For i = 1 To UBound(sArr)
If sArr(i, 1) = "No." Then fR = i + 1: Exit For
Next i
For i = fR To UBound(sArr)
Key = sArr(i, 6)
If Key = "" Then Exit For
If .exists(Key) Then
ik = .Item(Key)
Res(ik, 7) = Res(ik, 7) + 1
If ik < nR Then Res(1, 7) = Res(1, 7) + 1 Else Res(nR, 7) = Res(nR, 7) + 1
If Res(ik, 3) = "" Then
Res(ik, 3) = sArr(i, 2)
Else
Res(ik, 3) = Res(ik, 3) & ", " & sArr(i, 2)
End If
End If
Next i
k = k + 1
Res(k, 6) = "Total placements"
Res(k, 7) = Res(1, 7) + Res(nR, 7)
End With
[B7].Resize(k, 6).NumberFormat = "@"
[B7].Resize(k, 7) = Res
End Sub
Function ImportTextToExcel(ByVal FilesToOpen As String) As Variant
Dim fso As Object, TextSource As Object
Dim sArr As Variant, Res As Variant
Dim Str As String, tmp As String
Dim i As Long, k As Byte, S As Byte, j As Byte, n As Byte, sC As Byte
Dim dArr As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextSource = fs
penTextFile(FilesToOpen, 1, False, -2)
sArr = Split(TextSource.ReadAll, vbCrLf)
ReDim Res(1 To UBound(sArr), 1 To 1)
For i = LBound(sArr) To UBound(sArr)
Str = sArr(i)
S = Len(Str)
If S Then
k = 0
Test = False
For j = 1 To S - 1
If Mid(Str, j, 1) <> " " Then
k = k + 1
If sC < k Then
sC = k
ReDim Preserve Res(1 To UBound(sArr), 1 To k)
End If
tmp = ""
For n = j To S - 1
If Mid(Str, n, 2) <> " " Then
tmp = tmp & Mid(Str, n, 1)
Else
Res(i + 1, k) = tmp
j = n
Exit For
End If
Next n
End If
Next j
End If
Next i
ImportTextToExcel = Res
Set fso = Nothing: Set TextSource = Nothing
End Function
