Sub Main()
Dim aSheets(), Res(), Dic As Object
Dim FilesToOpen$, shName$
Dim i&, N&, k&
Dim Chk As Boolean
Chk = Application.FileDialog(msoFileDialogFilePicker).Show
If Not Chk Then Exit Sub
aSheets = Array("Line SMT1", "Line SMT2", "Line SMT3", "Line SMT2-3") ' Declare line name
Set Dic = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogFilePicker).SelectedItems
For N = 1 To .Count
FilesToOpen = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(N)
Call CreatRes(Res, Dic, shName, k, FilesToOpen)
For i = 1 To k
If Res(i, 3) <> Empty Then Res(i, 3) = Sort_Str_Num(Res(i, 3))
Next i
For i = 0 To 3 ' Rule for sheets
If aSheets(i) = "Line " & shName Then
With Sheets(aSheets(i))
.UsedRange.ClearContents
.Range("C2").Resize(k).NumberFormat = "@"
.Range("B2").Resize(k, 7) = Res
End With
End If
Next i
Dic.RemoveAll
Next N
End With
End Sub
Function Sort_Str_Num(ByVal iStr As String, Optional MaxLen& = 20) As String
'MaxLen: so ky tu lon nhat cua chuoi Sort
Dim S, sList As Object, tmp$, i&, j&
If iStr <> Empty Then
Set sList = CreateObject("System.Collections.ArrayList")
S = Split(iStr, ",")
For i = 0 To UBound(S)
tmp = S(i) & "0"
For j = 1 To Len(tmp)
If IsNumeric(Mid(tmp, j, 1)) Then
tmp = Mid(tmp, 1, j - 1) & Space(MaxLen - Len(tmp) + 1) & Mid(tmp, j, Len(tmp) - j)
sList.Add tmp
Exit For
End If
Next j
Next i
sList.Sort
Sort_Str_Num = Replace(Join(sList.ToArray, ","), " ", "")
Set sList = Nothing
End If
End Function
Private Sub CreatRes(Res, Dic, shName, k, ByVal FilesToOpen As String)
Dim fso As Object, TextSource As Object
Dim S, tArr, Sign(), iCol()
Dim str$, tmp$, iKey$, prName$
Dim i&, fR&, fR2&, eR&, N&
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2)
tArr = Split(TextSource.ReadAll, vbCrLf)
ReDim Res(1 To UBound(tArr), 1 To 8)
ReDim sArr(1 To UBound(tArr), 1 To 2)
For i = LBound(tArr) To UBound(tArr)
str = tArr(i)
If InStr(str, "Program Name") Then
prName = Replace((Split(Split(str, "=")(1), ".")(0)), " ", "")
ElseIf InStr(str, "Line Name") Then
S = Split(str, "=")
shName = Replace(S(UBound(S)), " ", "")
prName = prName
fR = i + 1: Exit For
End If
Next i
Sign = Array("Feeder Position", "Component Name", "Comment", " Type", "Component pitch", "Lane")
ReDim iCol(LBound(Sign) To UBound(Sign))
For i = fR To UBound(tArr)
str = tArr(i)
If InStr(str, Sign(0)) Then
eR = i - 1
For N = LBound(Sign) To UBound(Sign)
iCol(N) = InStr(str, Sign(N))
Next N
fR2 = i: Exit For
End If
Next i
k = 0
For i = fR2 To UBound(tArr)
str = tArr(i)
If InStr(str, Sign(0)) Then
k = k + 1: m = m + 1: ik = k
For N = i - 2 To i - 1
If InStr(tArr(N), "Machine") Then
Res(k, 1) = "Line Name " & shName & " / " & Application.Trim(tArr(N)) & " / Program Name: " & prName
Res(k, 4) = "Simulate time(s)"
Res(k, 6) = "No. of comp.ts"
Exit For
End If
Next N
ElseIf Mid(Application.Trim(str), 2, 1) = "-" Then
k = k + 1
Res(k, 1) = Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
iKey = Application.Trim(Mid(str, iCol(1), iCol(2) - iCol(1)))
Dic.Item(iKey) = Array(k, ik)
S = Split(iKey, " ")
Res(k, 2) = S(1): Res(k, 4) = S(0)
tmp = Application.Trim(Mid(str, iCol(3), iCol(4) - iCol(3)))
Res(k, 5) = Mid(tmp, InStr(1, tmp, " ") + 1, Len(tmp))
Res(k, 6) = Split(Application.Trim(Mid(str, iCol(4), iCol(5) - iCol(4))), " ")(0)
End If
Next i
Sign = Array("Placement ID", "X", "Component Name", "Centering")
ReDim iCol(LBound(Sign) To UBound(Sign))
For i = fR To eR
str = tArr(i)
If InStr(str, Sign(0)) Then
For N = LBound(Sign) To UBound(Sign)
iCol(N) = InStr(str, Sign(N))
Next N
fR = i + 1: Exit For
End If
Next i
k = k + 1
Res(k, 6) = "Total placements"
For i = fR To UBound(tArr)
str = tArr(i)
iKey = Application.Trim(Mid(str, iCol(2), iCol(3) - iCol(2)))
S = Dic.Item(iKey)
If TypeName(S) = "Variant()" Then
If Res(S(0), 3) = Empty Then
Res(S(0), 3) = Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
Else
Res(S(0), 3) = Res(S(0), 3) & "," & Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
End If
Res(S(0), 7) = Res(S(0), 7) + 1
Res(S(1), 7) = Res(S(1), 7) + 1
Res(k, 7) = Res(k, 7) + 1
End If
Next i
Set fso = Nothing: Set TextSource = Nothing
End Sub
