 Back to jkp-ads.com |
Ron de Bruin
|
 |
|
Back to jkp-ads.com |
Ron de Bruin
|
|
Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.
Luckily, Ron was kind enough to allow me to publish all of his Excel content here.
Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.
Kind regards
Jan Karel Pieterse
The macro below will copy every txt file that you select with
GetOpenFilename to a new workbook. If you select ten txt files in the folder
then you end up with 10 new worksheets in a newly created workbook. Each
worksheet will have the name of the txt file.
Note:
you can hold the CTRL key if you want to select more files
or use the Shift key to select
a block of files in
GetOpenFilename(With Ctrl a you select all files in the
folder).
I did not use all the properties for QueryTables in my macro
because a lot of them are already what I want by default. If you don't get
the results you want then record a macro when you perform the action
manually. Then look at the recorded code and add the code lines to the macro
Get_TXT_Files.
Copy all code in a normal module of your workbook
Alt F11
Insert Module
Paste the code
Alt q to go back to Excel
Alt F8 to open the macro dialog
Select the macro and press Run
This example is for Delimited txt files, see the example below this
macro for FixedWidth. Read the information in the macro Get_TXT_Files before
you try the macro. Maybe you want to use a different delimiter or change the
format of a column.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#Else
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#End If
Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
ChDirNet = CBool(lReturn <> 0)
End Function
Sub Get_TXT_Files()
'For Excel 2000 and higher
Dim Fnum As Long
Dim mysheet As Worksheet
Dim basebook As Workbook
Dim TxtFileNames As Variant
Dim QTable As QueryTable
Dim SaveDriveDir As String
Dim ExistFolder As Boolean
'Save the current dir
SaveDriveDir = CurDir
'You can change the start folder if you want for
'GetOpenFilename,you can use a network or local folder.
'For example ChDirNet("C:\Users\Ron\test")
'It now use Excel's Default File Path
ExistFolder = ChDirNet(Application.DefaultFilePath)
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If
TxtFileNames = Application.GetOpenFilename _
(filefilter:="TXT Files (*.txt), *.txt", MultiSelect:=True)
If IsArray(TxtFileNames) Then
On Error GoTo CleanUp
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add workbook with one sheet
Set basebook = Workbooks.Add(xlWBATWorksheet)
'Loop through the array with txt files
For Fnum = LBound(TxtFileNames) To UBound(TxtFileNames)
'Add a new worksheet for the name of the txt file
Set mysheet = Worksheets.Add(After:=basebook. _
Sheets(basebook.Sheets.Count))
On Error Resume Next
mysheet.Name = Right(TxtFileNames(Fnum), Len(TxtFileNames(Fnum)) - _
InStrRev(TxtFileNames(Fnum), "\", , 1))
On Error GoTo 0
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & TxtFileNames(Fnum), Destination:=Range("A1"))
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
'This example use xlDelimited
'See a example for xlFixedWidth below the macro
.TextFileParseType = xlDelimited
'Set your Delimiter to true
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
'Set the format for each column if you want (Default = General)
'For example Array(1, 9, 1) to skip the second column
.TextFileColumnDataTypes = Array(1, 9, 1)
'xlGeneralFormat General 1
'xlTextFormat Text 2
'xlMDYFormat Month-Day-Year 3
'xlDMYFormat Day-Month-Year 4
'xlYMDFormat Year-Month-Day 5
'xlMYDFormat Month-Year-Day 6
'xlDYMFormat Day-Year-Month 7
'xlYDMFormat Year-Day-Month 8
'xlSkipColumn Skip 9
' Get the data from the txt file
.Refresh BackgroundQuery:=False
End With
ActiveSheet.QueryTables(1).Delete
Next Fnum
'Delete the first sheet of basebook
On Error Resume Next
Application.DisplayAlerts = False
basebook.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0
CleanUp:
ChDirNet SaveDriveDir
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Example for txt files with a Fixed Width
Replace
:
'This example use xlDelimited 'See a example for xlFixedWidth below the macro .TextFileParseType = xlDelimited 'Set your Delimiter to true .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False
With
.TextFileParseType = xlFixedWidth
'Set the width for each column
.TextFileFixedColumnWidths = Array(5, 4, 8)
The macro below will copy every csv file that you select with
GetOpenFilename to a new workbook. If you select ten csv files in the folder
then you end up with 10 new worksheets in your workbook. Each worksheet will
have the name of the csv file.
Note: you can hold
the CTRL key if you want to select more files or use the
Shift key to select a block of files in
GetOpenFilename(With Ctrl a you select all files in the
folder).
Copy all code in a normal module of your workbook
Alt
F11
Insert Module
Paste the code
Alt q to go back to Excel
Alt
F8 to open the macro dialog
Select the macro and press Run
Note: if the result is not what you expect, it is because
you have no control over how Excel imports the
csv files. if you change
the extension from csv to txt you can use the macro above for txt files and
have more control (format of the columns)
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#Else
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#End If
Function ChDirNet(szPath As String) As Boolean
'based on Rob Bovey's code
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(szPath)
ChDirNet = CBool(lReturn <> 0)
End Function
Sub Get_CSV_Files()
'For Excel 2000 and higher
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim CSVFileNames As Variant
Dim SaveDriveDir As String
Dim ExistFolder As Boolean
'Save the current dir
SaveDriveDir = CurDir
'You can change the start folder if you want for
'GetOpenFilename,you can use a network or local folder.
'For example ChDirNet("C:\Users\Ron\test")
'It now use Excel's Default File Path
ExistFolder = ChDirNet(Application.DefaultFilePath)
If ExistFolder = False Then
MsgBox "Error changing folder"
Exit Sub
End If
CSVFileNames = Application.GetOpenFilename _
(filefilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
If IsArray(CSVFileNames) Then
On Error GoTo CleanUp
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Add workbook with one sheet
Set basebook = Workbooks.Add(xlWBATWorksheet)
'Loop through the array with csv files
For Fnum = LBound(CSVFileNames) To UBound(CSVFileNames)
Set mybook = Workbooks.Open(CSVFileNames(Fnum))
'Copy the sheet of the csv file after the last sheet in
'basebook (this is the new workbook)
mybook.Worksheets(1).Copy After:= _
basebook.Sheets(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = Right(CSVFileNames(Fnum), Len(CSVFileNames(Fnum)) - _
InStrRev(CSVFileNames(Fnum), "\", , 1))
On Error GoTo 0
mybook.Close savechanges:=False
Next Fnum
'Delete the first sheet of basebook
On Error Resume Next
Application.DisplayAlerts = False
basebook.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error GoTo 0
CleanUp:
ChDirNet SaveDriveDir
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub