Adrijus
10-19-2015, 01:03 PM
Hi Guys,
I am using Excel 2010 and to trying add Text Import Wizard into my code (provided below) so that a bulk of text files would be opened in a certain way. Needless to say that I am completely new to VBA and I had not created majority of code by my-self, just edited in a way that it works for me. Basically, I just need a bit of help to say where and how to put the wizard. I have recorded a macros of the wizard in two ways and I am not sure which is one is correct (please see bellow) probably none as both of them have constant file path where in the main code path is being retrieved from an array by using GetOpenFilename function. Apologies in advance if my question is not clear enough, if so please ask questions and I will clarify it.
The main code:
Sub Select_File_Or_Files_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
Dim NextWkbk As Workbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
Set NextWkbk = ActiveWorkbook
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Copy
ThisWorkbook.Activate
Sheets("Result").Activate
If Range("A1") = "" Then
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
NextWkbk.Close
On Error GoTo 0
Else
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
NextWkbk.Close
On Error GoTo 0
End If
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Text Import Wizard:
#1
ChDir _
"C:\Users\TheFolder"
Workbooks.OpenText Filename:= _
"C:\Users\TheFolder\TheFile" _
, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
, Comma:=False, Space:=False, Other:=True, OtherChar:="|", TrailingMinusNumbers:=True
#2
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\TheFolder\TheFile.TXT" _
, Destination:=Range("$A$1"))
.Name = "File"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Thank You in advance for any help :)
I am using Excel 2010 and to trying add Text Import Wizard into my code (provided below) so that a bulk of text files would be opened in a certain way. Needless to say that I am completely new to VBA and I had not created majority of code by my-self, just edited in a way that it works for me. Basically, I just need a bit of help to say where and how to put the wizard. I have recorded a macros of the wizard in two ways and I am not sure which is one is correct (please see bellow) probably none as both of them have constant file path where in the main code path is being retrieved from an array by using GetOpenFilename function. Apologies in advance if my question is not clear enough, if so please ask questions and I will clarify it.
The main code:
Sub Select_File_Or_Files_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
Dim NextWkbk As Workbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
Set NextWkbk = ActiveWorkbook
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Copy
ThisWorkbook.Activate
Sheets("Result").Activate
If Range("A1") = "" Then
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
NextWkbk.Close
On Error GoTo 0
Else
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
NextWkbk.Close
On Error GoTo 0
End If
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Text Import Wizard:
#1
ChDir _
"C:\Users\TheFolder"
Workbooks.OpenText Filename:= _
"C:\Users\TheFolder\TheFile" _
, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
, Comma:=False, Space:=False, Other:=True, OtherChar:="|", TrailingMinusNumbers:=True
#2
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\TheFolder\TheFile.TXT" _
, Destination:=Range("$A$1"))
.Name = "File"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Thank You in advance for any help :)