Glam Prestige Journal

Bright entertainment trends with youth appeal.

Excel 2016

Hi

I have a workbook called “Project” with a worksheet called, “Imported_Text”.

From sources online and through my own limited knowledge I have (against the odds) produced a sub (macro) that will open a user selected Tab delimited txt file, select only the columns I need and then excel places that in a worksheet. That all works fine, however, Excel always creates a new workbook and places the imported data in it which I do not want.

I need to be able to run the Sub macro from the “Project” work and have the imported data place into the existing “Imported_Text” worksheet but I am unable to work out how.

I know I can record a macro, perform the import text file and while the macro is still recording manually select and copy the data from the new work sheet, paste it in my “Imported_Text” worksheet, save my “Project” workbook, close without saving the new workbook that Excel created and stop the macro recording. This would give me the VBA code to achieve my goal but it seems a rather convoluted way of having to do things.

Can any perhaps suggest a better way?

For instance can the result of the array be captured (to the clipboard?) just before it writes the results to a new file and instead pasted into the worksheet of my choice?

This is my code - it is far from elegant but it works,

Sub ImportTXT() Dim Answer As VbMsgBoxResult Dim fDialog As FileDialog, result As Integer Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
'Optional: FileDialog properties fDialog.AllowMultiSelect = False fDialog.Title = "Select a file" fDialog.InitialFileName = "F:\"
'Optional: Add filters fDialog.Filters.Clear fDialog.Filters.Add "Text/CSV files", "*.txt" Answer = MsgBox("Are You Sure You Want To Import A Text File?", vbYesNo + vbCritical, "Import A Text File") If Answer = vbYes Then Application.ScreenUpdating = False FName = Application.GetOpenFilename()
' ImportTXT code copied from Macro recording Workbooks.OpenText FileName:=FName, Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier _ :=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:= _ False, Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array _ (1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 9), Array(8 _ , 9), Array(9, 9), Array(10, 1), Array(11, 9), Array(12, 9), Array(13, 9), Array(14, 9), _ Array(15, 9), Array(16, 9), Array(17, 9), Array(18, 9), Array(19, 9), Array(20, 9), Array( _ 21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 9)), TrailingMinusNumbers _ :=True End If
End Sub
8

3 Answers

Here's an example of a modification to your code, which allows for picking different files, and writing them to a worksheet in your active workbook.

I used a CSV file for testing, but:

  • The destination is hard-coded and you may want to change that.
  • You'll need to change the delimiter from comma, which I used for testing, to tab as per your requirements
  • You'll need to change the TextFileColumnDataTypes Array per your requirements.
  • If you want the destination to be the sheet where you run the macro from, then just change Set rDest = … to Set rDest = ActiveSheet.Cells(row,column)
Sub importText() Dim FName Dim rDest As Range Dim Answer As VbMsgBoxResult Dim fDialog As FileDialog, result As Integer Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
'Optional: FileDialog properties fDialog.AllowMultiSelect = False fDialog.Title = "Select a file" fDialog.InitialFileName = "F:\"
'Optional: Add filters fDialog.Filters.Clear fDialog.Filters.Add "Text/CSV files (*.txt; *.csv)", "*.txt; *.csv", 1 Answer = MsgBox("Are You Sure You Want To Import A Text File?", vbYesNo + vbCritical, "Import A Text File") If Answer = vbYes Then Application.ScreenUpdating = False Else Exit Sub End If FName = Application.GetOpenFilename(filefilter:="Text/CSV files (*.txt; *.csv),*.txt;*.csv", MultiSelect:=False) If FName = False Then Exit Sub Set rDest = Worksheets("sheet2").Cells(1, 1) With rDest.Worksheet.QueryTables.Add(Connection:= _ "TEXT;" & FName, Destination:=rDest) .Name = "new 1_1" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = 1 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = True .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With
End Sub
1

This VBA Macro solves the issue.

 Sub ImportTXTFile() Dim vPath As Variant Dim wb As Excel.Workbook Dim ws As Excel.Worksheet Dim rng As Range, TextLine As String Dim rw As Long, col As Long Dim i As Long, j As Long, ary() As String, a As Variant Set wb = Excel.ActiveWorkbook vPath = Application.GetOpenFilename("TXT (Comma Separated) (*.Txt),*.Txt" _ , 1, "Select the file", , False) MsgBox vPath Set rng = Application.InputBox(Prompt:="Pick the Sheet & a Cell", Type:=8) rng.Parent.Parent.Activate rng.Parent.Activate rw = rng(1).Row col = rng(1).Column Close #1 i = rw Open vPath For Input As #1 Do While Not EOF(1) Line Input #1, TextLine ary = Split(TextLine, ",") j = col For Each a In ary Cells(i, j).Value = a j = j + 1 Next a i = i + 1 Loop Close 1 End Sub

How it works:

  • RUN the Macro, shows the File Picker.
  • Select the Text file.
  • Macro shows the File with Path, finish with Ok.
  • It Prompts to select the Sheet & the Cell to Paste the Imported data.

N.B.

  • In this code (*.Txt),*.Txt" is editable it should *.CSV also.

  • Save the Workbook as Macro Enabled.

2

I made a similar macro that reads the file in a single operation, and it also cleans up the data before placing items in the cells:

Sub RoundedRectangle1_Click() Dim Ret Ret = Application.GetOpenFilename("Text Files (*.txt),*.txt") If Ret <> False Then readFile (Ret) End If
End Sub
Sub readFile(fname) Dim MyData As String, strData() As String, tabData() As String Open fname For Binary As #1 MyData = Space$(LOF(1)) Get #1, , MyData Close #1 MyData = Replace(MyData, vbTab + vbTab, vbTab) strData() = Split(MyData, vbLf) For Row = 1 To UBound(strData) + 1 tabData() = Split(strData(Row - 1), vbTab) For Column = 1 To UBound(tabData) + 1 cellStr = Trim(tabData(Column - 1)) If (Not cellStr = vbNullString) Then Cells(Row, Column) = cellStr End If Next Next
End Sub

Notes

  • This code will write over many existing cells in your spreadsheet, so beware
  • I replaced double tabs with single tabs, and that fixed my cell placement problems in rows. You may need more sophisticated replacements there
  • The double loop limits were derived empirically
  • I had to use vbLf for windows txt files and vbNl for mac txt files
  • This code places cells starting at 1,1, but you can change it to suit your needs

You can read this info in article form that I wrote at my website for my open source projects:

4

Your Answer

Sign up or log in

Sign up using Google Sign up using Facebook Sign up using Email and Password

Post as a guest

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Related Journals