Fixed width import - remove trailing empty columns

[NickWels]

Hey

I have created a form where I can enter lengths of up to 40 fields to import from text a fixed width data file
Even though the data file I am importing is 14 fields, excel is opening columns up to XFC, so making the opening process very long

Below is part of the current VBA code I have created. (Site wont let me paste it all!)
I would like to only import the fields specified in the user form, not every possible blank field excel can add to the end!
Any help would be appreciated



Public Function GetLastColumnNumber(ByVal ws As Worksheet) As Long
On Error GoTo handler
GetLastColumnNumber = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
GoTo finish
handler:
finish:
Call Cells.Find("", , XlFindLookIn.xlValues, XlLookAt.xlPart, XlSearchOrder.xlByColumns, XlSearchDirection.xlNext)
End Function

Public Function GetLastRowNumber(ByVal ws As Worksheet) As Long
On Error GoTo handler
GetLastRowNumber = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
GoTo finish
handler:
finish:
Call Cells.Find("", , XlFindLookIn.xlValues, XlLookAt.xlPart, XlSearchOrder.xlByColumns, XlSearchDirection.xlNext)
End Function

[NickWels]

Other code

Public Function GetExtension(ByVal file As String) As String
On Error Resume Next
Dim ext As String
ext = ""
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
ext = "." & fso.GetExtensionName(file)
finish:
On Error GoTo 0
GetExtension = ext
End Function

Sub SetDefaultBrowseLocation()
On Error Resume Next
Dim pathStr As String
pathStr = "P:\Data Processing\Jobs"
ChDrive (pathStr)
ChDir (pathStr)
On Error GoTo 0
End Sub

[NickWels]

Other code
One big sub, part 1


Sub MergedFixedWidthImport()
'Stops the screen updating whilst processing and importing from text
Application.ScreenUpdating = False
'Declarations
Dim previousName As String
Dim newName As String
previousName = ""
newName = ""
Dim myName As String
Dim tempName As String
Dim FName As String
Dim myFile
Dim MyPath
Dim delimStr As String
Dim ftStr As String
Dim ext As String
Dim strFileToOpen
Dim tq As XlTextQualifier
tq = xlTextQualifierDoubleQuote
Dim lastRow As Long
Dim lastCol As Long
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim flagCol As Long
Dim encoding As Long
Dim tqConsec As Boolean
tqConsec = False
Dim autoFitCol As Boolean
autoFitCol = True
Set fso = CreateObject("Scripting.FileSystemObject")
encoding = 1252
'Setup array to hold 100000 long variables and set all of them to 2 for the text import (sets the column data type to xlTextFormat)
Dim colDataTypesArr(1 To 100000) As Long
Dim i As Long
For i = 1 To UBound(colDataTypesArr)
colDataTypesArr(i) = 2
Next i
Call SetDefaultBrowseLocation
On Error GoTo finish

[NickWels]

Part 2

'Pick up the fixed width column lengths from the worksheet
Dim colWidthsArr() As Long
Dim widthCell As Range
Dim counter As Long
counter = 0
For Each widthCell In ThisWorkbook.Sheets("Setup").Range("B2:B100").Cells
If IsNumeric(widthCell.Value) = False Or widthCell.Value <= 0 Or widthCell.Value = vbNullString Then
GoTo continueFromLoop
End If
If IsNumeric(widthCell.Value) And widthCell.Value > 0 Then
ReDim Preserve colWidthsArr(counter)
colWidthsArr(counter) = widthCell.Value
counter = counter + 1
End If
Next widthCell
continueFromLoop:
If counter = 0 Then GoTo finish
'Open as multifile code
'Open the file dialog box to allow the user to choose files to open
Set MyPath = Application.FileDialog(msoFileDialogFilePicker)
'Set the properties of the open file dialog
MyPath.Title = "Please choose " & "fixed width" & " files to open"
MyPath.Filters.Clear
MyPath.Filters.Add ftStr, ext
MyPath.Filters.Add "All files", "*.*"

[NickWels]

Part 3


'Show the open file dialog
If MyPath.Show Then
'set allow multiselect to true
MyPath.AllowMultiSelect = True
Set newbook = Workbooks.Add
newbook.Activate
'Set the active sheet cells to text format before importing
ActiveSheet.Cells.NumberFormat = "at sign (forum blocking)"
For Each strFileToOpen In MyPath.SelectedItems
'Test if the user has selected anything and if not go to finish
If strFileToOpen = "" Or strFileToOpen = "False" Then
GoTo finish
End If
On Error GoTo finish
lastRow = Module1.GetLastRowNumber(newbook.Sheets(1))
Set myFile = fso.GetFile(strFileToOpen)

[NickWels]

Part 4 and end

'Add the querytable to the active sheet and open the user selected file as text using the "TEXT;" qualifier before the filepath
With ActiveSheet.QueryTables.Add( _
Connection:="TEXT;" & strFileToOpen, _
Destination:=newbook.Sheets(1).Range(Cells(lastRow + 1, 1).Address))
'Set the properties of the QueryTable
.Name = "Sheet1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = autoFitCol
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = encoding
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = tq
.TextFileConsecutiveDelimiter = tqConsec
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
'User defined column widths variable used below
.TextFileFixedColumnWidths = colWidthsArr
'The below line will use the array that was set up above and will do the equivalent of hilighting all columns and setting them to text
.TextFileColumnDataTypes = colDataTypesArr
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
If autoFitCol = True Then
newbook.Sheets(1).Columns.AutoFit
End If
End If
GoTo finish
sheetHandler:
MsgBox "Problem with active sheet"
GoTo finish
sheetNameHandler:
MsgBox "Sheet name already exists in this workbook." & vbNewLine & "Please try again and select to open in a new workbook."
GoTo finish
'On finish - turn the screen updating back on
finish:
Application.ScreenUpdating = True
End Sub

[NickWels]

If an admin can move this to excel section not outlook... my apologies :D

[Aussiebear]

Welcome to VBAX NickWels. Admin have set it up so no one can flood the forum with their first few posts. Apologies accepted for posting in the wrong subform, and you will notice.... you should wrap your code with code tags.....

[NickWels]

thanks, wasn't aware but noted for future :)

[NickWels]

Can anyone help?!
Short version... how to limit impot of columns to what you have selected using a user form, not max amount possible in excel

[Aussiebear]

As I understand it this is all of your code. I find it difficult to concentrate on linking code written in different posts


Public Function GetLastColumnNumber(ByVal ws As Worksheet) As Long
On Error GoTo handler
GetLastColumnNumber = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
GoTo finish
handler:
finish:
Call Cells.Find("", , XlFindLookIn.xlValues, XlLookAt.xlPart, XlSearchOrder.xlByColumns, XlSearchDirection.xlNext)
End Function

Public Function GetLastRowNumber(ByVal ws As Worksheet) As Long
On Error GoTo handler
GetLastRowNumber = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
GoTo finish
handler:
finish:
Call Cells.Find("", , XlFindLookIn.xlValues, XlLookAt.xlPart, XlSearchOrder.xlByColumns, XlSearchDirection.xlNext)
End Function

Public Function GetExtension(ByVal file As String) As String
On Error Resume Next
Dim ext As String
ext = ""
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
ext = "." & fso.GetExtensionName(file)
finish:
On Error GoTo 0
GetExtension = ext
End Function

Sub SetDefaultBrowseLocation()
On Error Resume Next
Dim pathStr As String
pathStr = "P:\Data Processing\Jobs"
ChDrive (pathStr)
ChDir (pathStr)
On Error GoTo 0
End Sub

Sub MergedFixedWidthImport()
'Stops the screen updating whilst processing and importing from text
Application.ScreenUpdating = False
'Declarations
Dim previousName As String
Dim newName As String
previousName = ""
newName = ""
Dim myName As String
Dim tempName As String
Dim FName As String
Dim myFile
Dim MyPath
Dim delimStr As String
Dim ftStr As String
Dim ext As String
Dim strFileToOpen
Dim tq As XlTextQualifier
tq = xlTextQualifierDoubleQuote
Dim lastRow As Long
Dim lastCol As Long
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim flagCol As Long
Dim encoding As Long
Dim tqConsec As Boolean
tqConsec = False
Dim autoFitCol As Boolean
autoFitCol = True
Set fso = CreateObject("Scripting.FileSystemObject")
encoding = 1252
'Setup array to hold 100000 long variables and set all of them to 2 for the text import (sets the column data type to xlTextFormat)
Dim colDataTypesArr(1 To 100000) As Long
Dim i As Long
For i = 1 To UBound(colDataTypesArr)
colDataTypesArr(i) = 2
Next i
Call SetDefaultBrowseLocation
On Error GoTo finish
'Pick up the fixed width column lengths from the worksheet
Dim colWidthsArr() As Long
Dim widthCell As Range
Dim counter As Long
counter = 0
For Each widthCell In ThisWorkbook.Sheets("Setup").Range("B2:B100").Cells
If IsNumeric(widthCell.Value) = False Or widthCell.Value <= 0 Or widthCell.Value = vbNullString Then
GoTo continueFromLoop
End If
If IsNumeric(widthCell.Value) And widthCell.Value > 0 Then
ReDim Preserve colWidthsArr(counter)
colWidthsArr(counter) = widthCell.Value
counter = counter + 1
End If
Next widthCell
continueFromLoop:
If counter = 0 Then GoTo finish
'Open as multifile code
'Open the file dialog box to allow the user to choose files to open
Set MyPath = Application.FileDialog(msoFileDialogFilePicker)
'Set the properties of the open file dialog
MyPath.Title = "Please choose " & "fixed width" & " files to open"
MyPath.Filters.Clear
MyPath.Filters.Add ftStr, ext
MyPath.Filters.Add "All files", "*.*"
'Show the open file dialog
If MyPath.Show Then
'set allow multiselect to true
MyPath.AllowMultiSelect = True
Set newbook = Workbooks.Add
newbook.Activate
'Set the active sheet cells to text format before importing
ActiveSheet.Cells.NumberFormat = "at sign (forum blocking)"
For Each strFileToOpen In MyPath.SelectedItems
'Test if the user has selected anything and if not go to finish
If strFileToOpen = "" Or strFileToOpen = "False" Then
GoTo finish
End If
On Error GoTo finish
lastRow = Module1.GetLastRowNumber(newbook.Sheets(1))
Set myFile = fso.GetFile(strFileToOpen)
'Add the querytable to the active sheet and open the user selected file as text using the "TEXT;" qualifier before the filepath
With ActiveSheet.QueryTables.Add( _
Connection:="TEXT;" & strFileToOpen, _
Destination:=newbook.Sheets(1).Range(Cells(lastRow + 1, 1).Address))
'Set the properties of the QueryTable
.Name = "Sheet1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = autoFitCol
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = encoding
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = tq
.TextFileConsecutiveDelimiter = tqConsec
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
'User defined column widths variable used below
.TextFileFixedColumnWidths = colWidthsArr
'The below line will use the array that was set up above and will do the equivalent of highlighting all columns and setting them to text
.TextFileColumnDataTypes = colDataTypesArr
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next
If autoFitCol = True Then
newbook.Sheets(1).Columns.AutoFit
End If
End If
GoTo finish
sheetHandler:
MsgBox "Problem with active sheet"
GoTo finish
sheetNameHandler:
MsgBox "Sheet name already exists in this workbook." & vbNewLine & "Please try again and select to open in a new workbook."
GoTo finish
'On finish - turn the screen updating back on
finish:
Application.ScreenUpdating = True
End Sub


Maybe this will assist other to peruse your code. Everyone codes differently, however some of my immediate queries are;
1. The use of double error handlers in blocks of code. Is this necessary?
2. Your use of "Dim fso" but don't actually dim it as anything. Is that good code practise?
3. Your use of "Handler:" but don't actually use it. Can it be deleted?
4. Your use of "ext = """, but then three lines later actually set the "ext = "." & fso.GetExtensionName(file)". Are you over complicating the code?
5. Your setting of fso "Set fso = CreateObject("Scripting.FileSystemObject") twice within 8 lines. Is this necessary?

[p45cal]

1. I'm not sure this line:
ActiveSheet.Cells.NumberFormat = "@" is necessary since you've set an array and used it in the query:
.TextFileColumnDataTypes = colDataTypesArr but it's not easy for me to test. Could you?
That first line sets ALL cells on the sheet, all 17,179,869,184 of them to text format and I think this might take up some time but I could be wrong.

2. Your colDataTypesArr has 100,000 members; does it need to be so big? and how long does the query take to add that property? and does it even cope with the difference between the number of columns being imported and the size of that array?
Perhaps reduce its size to 40 (from your 'I can enter lengths of up to 40 fields') or 99 (the number of cells in B2:B100)?

[NickWels]

Thanks for the help. I have made both changes, the speed to import is now almost instant which is great!!
All imported fields are correct.
But i now also have all original data, still fixed width in Col CV
This wasn't happening before. Any ideas?

[p45cal]

Progress is being made, but it looks like you're struggling a bit with the code. So it looks like you've researched how to do what you want and want to adapt code you've found on the web.
The code sets some values and arrays for the Querytable to do its import job properly; you want to import a fixed width text file and you want to tell it (a) the columns layout of the text file (the column widths, your colWidthsArr) and (b) the type of data in those columns (your colDataTypesArr) so that Excel correctly interprets that data. These two go hand in hand.
Have a look at https://learn.microsoft.com/en-us/office/vba/api/Excel.QueryTable.TextFileFixedColumnWidths where you'll note 2 things: 'If you specify columns that exceed the width of the text file, those values are ignored.' and 'If the width of the text file is greater than the total width of columns that you specify, the balance of the text file is imported into an additional column.'
This looks to be the case for you, and what needs to happen is for that last column not to be imported.

Also have a look at https://learn.microsoft.com/en-us/office/vba/api/Excel.QueryTable.TextFileColumnDataTypes noting 'Use the XlColumnDataType constants to specify' where the XlColumnDataType links to https://learn.microsoft.com/en-us/office/vba/api/excel.xlcolumndatatype which shows how you've used the value 2 (xlTextFormat) to import as text for all your fields, but note there's also 9 (xlSkipColumn) to say that the column is not parsed (it's skipped), which is probably what you want.
So lets say you have a text file with an overall width of 100 characters, you want to import the first 3 columns only, of widths:
(5,10,5)
which totals only 20 characters. You specify that they're all to come in as Text so you set up your colDataTypesArr to contain:
(2,2,2)
If you run with that you'll get your 3 columns brought in properly, but you'll get the balance (80 characters wide) in a fourth column with the default General type. I think this is what you're seeing in column CV. What I think you want to do is to add a 4th xlSkipColumn element to handle that 4th column by adding a 4th element to your colDataTypesArr making it:
(2,2,2,9)

I suspect the learning curve is a little steep, especially if you're in a hurry for this to work. There's a fair amount of code that you probably don't need, and some of it needs rearranging so that your column widths and column types tally properly, depending on how far your data goes down in column B of the Setup sheet.

I'll offer to write some of this code for you but I see that you don't want some data to be in the public domain, however, if you don't mind just me seeing it I would need your workbook (bare bones just for this project preferably) and one or two samples of untouched text files for import.
Send me a Private Message here if you want to go ahead with that, otherwise we can progress in baby steps here, but it might take some time.

[NickWels]

Thank you for the extensive reply. I will read through all the links you have added and will reach out if I need any help :)