' Verified!
Code: Select all
Sub Get_Unique_K_Zones_FromFile()
'
' Read K zone file and import a list of unique K zones.
' Verified!
'
Dim fso As Object
Dim ts As Object
Dim dict As Object
Dim filePath As String
Dim inFN As String
Dim line As String
Dim parts As Variant
Dim zone As String
Dim wsKSdb As Worksheet
Dim key As Variant
Dim rowNum As Long
' Parameters.
folderNm = Worksheets("macro").Cells(6, "D")
inFN = Worksheets("macro").Cells(6, "E") ' Data file name.
Set wsKSdb = ThisWorkbook.Sheets("KSdb")
wsKSdb.Range("P2:P1000").ClearContents ' colum P for the K list.
'=== 1. Set file path ===
filePath = ActiveWorkbook.Path & "\" & folderNm & "\" & inFN
'=== 2. Create objects ===
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(filePath, 1) ' 1 = ForReading
Set dict = CreateObject("Scripting.Dictionary")
'=== 3. Read line-by-line ===
Do While Not ts.AtEndOfStream
line = ts.ReadLine
If Len(line) > 0 Then
'parts = Split(line, vbTab) ' change vbTab to "," if CSV
parts = Split(Application.Trim(line), " ")
If UBound(parts) >= 1 Then
zone = Trim(parts(1)) ' second column (0-based index)
If Len(zone) > 0 Then
If Not dict.Exists(zone) Then
dict.Add zone, True
End If
End If
End If
End If
Loop
ts.Close
'=== 4. Copy K zone numbers without sorting.
'rowNum = 2
'For Each key In dict.Keys
' wsKSdb.Cells(rowNum, 16).Value = key ' Column P = 16
' rowNum = rowNum + 1
'Next key
'=== 4. Get keys and sort them ===
Keys = dict.Keys
' Simple bubble sort (works fine for moderate unique counts)
For i = LBound(Keys) To UBound(Keys) - 1
For j = i + 1 To UBound(Keys)
If Int(Keys(j)) < Int(Keys(i)) Then ' Compare them as integers.
temp = Keys(i)
Keys(i) = Keys(j)
Keys(j) = temp
End If
Next j
Next i
'=== 5. Output to sheet ===
' K zone numbers are copied to column P. Start from Row 2.
rowNum = 2
For i = LBound(Keys) To UBound(Keys)
wsKSdb.Cells(rowNum, 16).Value = Keys(i) ' Column P = 16
rowNum = rowNum + 1
Next i
MsgBox "Done - " & dict.Count & " unique zones found.", vbInformation
End Sub