mvidas
02-13-2006, 09:33 AM
Hi Everyone,
This code is by no means finished (just try and follow it!), but I'm curious to see how this works for other people.
The only thing you need for this? A fixed-width text file. This was originally created for someone who had a somewhat-changing fixed width file they wanted to automate for import. I just want people to try it, and tell me if/why it would not work for them. I understand it will not work for files that look like:
AAAAABBCCCCCCDDDDEEEFFFFFFGGGGHHHIIII
(no spaces possible between entries)
But I'm still interested in seeing how it works for others. In my testing it almost always worked, but I was testing it with specific-format files.
Just copy/paste the following into a standard module, and run the ImportFixedWidthTest sub. It will ask you for the filename to import:Sub ImportFixedWidthTest()
Dim FileCont() As String, Cnt As Long, vFF As Long, vFile As String, tStr As String
Dim tempArr() As Long, numItems() As Long, i As Long, itmCnt As Long, itmCount As Long
Dim RegEx As Object, RegC As Object, MaxFields As Long, MaxFields2 As Long
Dim FieldCnt As Long, FieldWidths() As Long, AllFields(), LastFld As Long
Dim AllFieldWidths() As Long, j As Long, StartPos() As Long
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Global = True
vFile = Application.GetOpenFilename("Text Files,*.txt,AllFiles,*.*")
If LCase(vFile) = "false" Then Exit Sub
vFF = FreeFile
Open vFile For Input As #vFF
Do Until EOF(vFF)
Line Input #vFF, tStr
ReDim Preserve FileCont(Cnt)
FileCont(Cnt) = tStr
Cnt = Cnt + 1
Loop
Close #7
ReDim AllFields(Cnt - 1)
RegEx.Pattern = "\S\s|\S$"
itmCnt = 0
ReDim numItems(1, itmCnt)
For Cnt = 0 To UBound(FileCont)
Set RegC = RegEx.Execute(FileCont(Cnt))
itmCount = RegC.Count
ReDim tempArr(itmCount - 1)
LastFld = 0
For i = 0 To itmCount - 1
tempArr(i) = RegC(i).FirstIndex + 1 - LastFld
LastFld = RegC(i).FirstIndex + 1
Next
AllFields(Cnt) = tempArr
For i = 0 To itmCnt - 1
If numItems(0, i) = itmCount Then Exit For
Next
If i = itmCnt Then
ReDim Preserve numItems(1, itmCnt)
numItems(0, itmCnt) = itmCount
numItems(1, itmCnt) = 1
itmCnt = itmCnt + 1
Else
numItems(1, i) = numItems(1, i) + 1
End If
Next
MaxFields = 0
MaxFields2 = -1
For i = 0 To itmCnt - 1
If numItems(1, i) > MaxFields Then
MaxFields = numItems(1, i)
MaxFields2 = 0
FieldCnt = numItems(0, i)
ElseIf numItems(1, i) = MaxFields Then
MaxFields2 = MaxFields
End If
Next
If MaxFields2 <> 0 Then
MsgBox "Unable to determine number of fields."
Exit Sub
End If
ReDim AllFieldWidths(FieldCnt - 1, 0)
Cnt = 0
For j = 0 To UBound(AllFields)
If UBound(AllFields(j)) = FieldCnt - 1 Then
ReDim Preserve AllFieldWidths(FieldCnt - 1, Cnt)
For i = 0 To FieldCnt - 1
AllFieldWidths(i, Cnt) = AllFields(j)(i)
Next
Cnt = Cnt + 1
End If
Next
ReDim FieldWidths(FieldCnt - 1)
ReDim StartPos(FieldCnt - 1)
StartPos(0) = 1
For i = 0 To FieldCnt - 1
ReDim tempArr(UBound(FileCont))
For j = 0 To Cnt - 1
tempArr(j) = AllFieldWidths(i, j)
Next
FieldWidths(i) = lMode(tempArr)
If FieldWidths(i) = 0 Then
MsgBox "Unable to determine field widths"
Exit Sub
End If
If i > 0 Then
StartPos(i) = StartPos(i - 1) + FieldWidths(i - 1)
End If
Next
Application.ScreenUpdating = False
i = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = i
For i = 0 To UBound(FileCont)
For j = 0 To FieldCnt - 1
Cells(i + 1, j + 1) = Mid(FileCont(i), StartPos(j), IIf(j = FieldCnt - 1, _
Len(FileCont(i)), FieldWidths(j)))
Next
Next
Application.ScreenUpdating = True
Set RegC = Nothing
Set RegEx = Nothing
End Sub
Function lMode(vValues() As Long)
Dim MaxCt As Long, MaxCt2 As Long, tMode As Long, ctValues() As Long, iCnt As Long
Dim i As Long, j As Long
iCnt = 0
ReDim ctValues(1, iCnt)
For i = 0 To UBound(vValues)
For j = 0 To iCnt - 1
If ctValues(0, j) = vValues(i) Then Exit For
Next
If j = iCnt Then
ReDim Preserve ctValues(1, iCnt)
ctValues(0, iCnt) = vValues(i)
ctValues(1, iCnt) = 1
iCnt = iCnt + 1
Else
ctValues(1, j) = ctValues(1, j) + 1
End If
Next
MaxCt = 0
MaxCt2 = -1
tMode = 0
For i = 0 To iCnt - 1
If ctValues(1, i) > MaxCt Then
MaxCt = ctValues(1, i)
MaxCt2 = 0
tMode = ctValues(0, i)
ElseIf ctValues(1, i) = MaxCt Then
MaxCt2 = MaxCt
End If
Next
If MaxCt2 <> 0 Then tMode = 0
lMode = tMode
End FunctionAgain, any feedback is much appreciated
Matt
This code is by no means finished (just try and follow it!), but I'm curious to see how this works for other people.
The only thing you need for this? A fixed-width text file. This was originally created for someone who had a somewhat-changing fixed width file they wanted to automate for import. I just want people to try it, and tell me if/why it would not work for them. I understand it will not work for files that look like:
AAAAABBCCCCCCDDDDEEEFFFFFFGGGGHHHIIII
(no spaces possible between entries)
But I'm still interested in seeing how it works for others. In my testing it almost always worked, but I was testing it with specific-format files.
Just copy/paste the following into a standard module, and run the ImportFixedWidthTest sub. It will ask you for the filename to import:Sub ImportFixedWidthTest()
Dim FileCont() As String, Cnt As Long, vFF As Long, vFile As String, tStr As String
Dim tempArr() As Long, numItems() As Long, i As Long, itmCnt As Long, itmCount As Long
Dim RegEx As Object, RegC As Object, MaxFields As Long, MaxFields2 As Long
Dim FieldCnt As Long, FieldWidths() As Long, AllFields(), LastFld As Long
Dim AllFieldWidths() As Long, j As Long, StartPos() As Long
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Global = True
vFile = Application.GetOpenFilename("Text Files,*.txt,AllFiles,*.*")
If LCase(vFile) = "false" Then Exit Sub
vFF = FreeFile
Open vFile For Input As #vFF
Do Until EOF(vFF)
Line Input #vFF, tStr
ReDim Preserve FileCont(Cnt)
FileCont(Cnt) = tStr
Cnt = Cnt + 1
Loop
Close #7
ReDim AllFields(Cnt - 1)
RegEx.Pattern = "\S\s|\S$"
itmCnt = 0
ReDim numItems(1, itmCnt)
For Cnt = 0 To UBound(FileCont)
Set RegC = RegEx.Execute(FileCont(Cnt))
itmCount = RegC.Count
ReDim tempArr(itmCount - 1)
LastFld = 0
For i = 0 To itmCount - 1
tempArr(i) = RegC(i).FirstIndex + 1 - LastFld
LastFld = RegC(i).FirstIndex + 1
Next
AllFields(Cnt) = tempArr
For i = 0 To itmCnt - 1
If numItems(0, i) = itmCount Then Exit For
Next
If i = itmCnt Then
ReDim Preserve numItems(1, itmCnt)
numItems(0, itmCnt) = itmCount
numItems(1, itmCnt) = 1
itmCnt = itmCnt + 1
Else
numItems(1, i) = numItems(1, i) + 1
End If
Next
MaxFields = 0
MaxFields2 = -1
For i = 0 To itmCnt - 1
If numItems(1, i) > MaxFields Then
MaxFields = numItems(1, i)
MaxFields2 = 0
FieldCnt = numItems(0, i)
ElseIf numItems(1, i) = MaxFields Then
MaxFields2 = MaxFields
End If
Next
If MaxFields2 <> 0 Then
MsgBox "Unable to determine number of fields."
Exit Sub
End If
ReDim AllFieldWidths(FieldCnt - 1, 0)
Cnt = 0
For j = 0 To UBound(AllFields)
If UBound(AllFields(j)) = FieldCnt - 1 Then
ReDim Preserve AllFieldWidths(FieldCnt - 1, Cnt)
For i = 0 To FieldCnt - 1
AllFieldWidths(i, Cnt) = AllFields(j)(i)
Next
Cnt = Cnt + 1
End If
Next
ReDim FieldWidths(FieldCnt - 1)
ReDim StartPos(FieldCnt - 1)
StartPos(0) = 1
For i = 0 To FieldCnt - 1
ReDim tempArr(UBound(FileCont))
For j = 0 To Cnt - 1
tempArr(j) = AllFieldWidths(i, j)
Next
FieldWidths(i) = lMode(tempArr)
If FieldWidths(i) = 0 Then
MsgBox "Unable to determine field widths"
Exit Sub
End If
If i > 0 Then
StartPos(i) = StartPos(i - 1) + FieldWidths(i - 1)
End If
Next
Application.ScreenUpdating = False
i = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = i
For i = 0 To UBound(FileCont)
For j = 0 To FieldCnt - 1
Cells(i + 1, j + 1) = Mid(FileCont(i), StartPos(j), IIf(j = FieldCnt - 1, _
Len(FileCont(i)), FieldWidths(j)))
Next
Next
Application.ScreenUpdating = True
Set RegC = Nothing
Set RegEx = Nothing
End Sub
Function lMode(vValues() As Long)
Dim MaxCt As Long, MaxCt2 As Long, tMode As Long, ctValues() As Long, iCnt As Long
Dim i As Long, j As Long
iCnt = 0
ReDim ctValues(1, iCnt)
For i = 0 To UBound(vValues)
For j = 0 To iCnt - 1
If ctValues(0, j) = vValues(i) Then Exit For
Next
If j = iCnt Then
ReDim Preserve ctValues(1, iCnt)
ctValues(0, iCnt) = vValues(i)
ctValues(1, iCnt) = 1
iCnt = iCnt + 1
Else
ctValues(1, j) = ctValues(1, j) + 1
End If
Next
MaxCt = 0
MaxCt2 = -1
tMode = 0
For i = 0 To iCnt - 1
If ctValues(1, i) > MaxCt Then
MaxCt = ctValues(1, i)
MaxCt2 = 0
tMode = ctValues(0, i)
ElseIf ctValues(1, i) = MaxCt Then
MaxCt2 = MaxCt
End If
Next
If MaxCt2 <> 0 Then tMode = 0
lMode = tMode
End FunctionAgain, any feedback is much appreciated
Matt