Data Import and Format

mrrcx1

New Member
Joined
Jul 18, 2012
Messages
24
Hi,

I am trying to import many txt files at the same time.
Each text file has 3 columns worth of data.

I would like them to be imported to the same worksheet next to each other without spaces.

I am toying with some code now that puts the imported files in new worksheets in the workbook but I do not want this.

Sub Data_Import()

Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "" Then xStrPath = xStrPath & ""
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Then
MsgBox "No files found", vbInformation, "Kutools for Excel"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Set xToBook = ThisWorkbook
If xFiles.Count > 0 Then
For I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
On Error GoTo 0
xWb.Close False
Next
End If
End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Not sure if your import data has anything in column A, but here's one method.

(use code tags to make your code more readable) (# symbol from ribbon)
Code:
Sub Data_Import()


Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
[COLOR=#ff0000][B]Dim rTarg As Range[/B][/COLOR]
[COLOR=#ff0000][B]Dim xToSheet As Worksheet[/B][/COLOR]


Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"


If xFileDialog.Show = -1 Then
    xStrPath = xFileDialog.SelectedItems(1)
End If


If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "" Then xStrPath = xStrPath & ""
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Then
    MsgBox "No files found", vbInformation, "Kutools for Excel"
    Exit Sub
End If


Do While xFile <> ""
    xFiles.Add xFile, xFile
    xFile = Dir()
Loop


Set xToBook = ThisWorkbook
[COLOR=#ff0000][B]'set destination worksheet[/B][/COLOR]
[COLOR=#ff0000][B]Set xToSheet = xToBook.Sheets("Sheet1") 'Change me before running[/B][/COLOR]
[COLOR=#ff0000][B]Set rTarg = xToSheet.[A1][/B][/COLOR]


If xFiles.Count > 0 Then
    For I = 1 To xFiles.Count
        Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
        xWb.Worksheets(1).Copy[B][COLOR=#ff0000] rTarg[/COLOR][/B]
        xWb.Close False
[B][COLOR=#ff0000]        With xToSheet[/COLOR][/B]
[B][COLOR=#ff0000]            Set rTarg = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)[/COLOR][/B]
[B][COLOR=#ff0000]        End With[/COLOR][/B]
    Next
End If
End Sub

This code copies all of the data from the first sheet of the given workbook selection to "Sheet1" of your destination workbook. It then looks for the last used cell in column A of your destination sheet and sets the range to the first blank cell below the last used cell in column A & continues the loop.
 
Upvote 0
Hi,
I do not have a need to copy from workbook to workbook. Just import many txt files, each with 3 columns of data (say a, b, c) and paste them on 1 sheet in a workbook.
Once the 1st is pasted, the next will need to be pasted starting in the next open column (d, e, f)...etc

Thanks for the tip on posting code!
 
Upvote 0
#2 does as requested (except all in first 3 columns) by taking data from each text file and sending to the target sheet. To fix the column thing, change the last with statement to this:
Code:
        With xToSheet
            Set rTarg = .Cells(1, .Columns.Count).End(xlToLeft ).Offset(, 1)
        End With
 
Upvote 0
#2 does as requested (except all in first 3 columns) by taking data from each text file and sending to the target sheet. To fix the column thing, change the last with statement to this:
Code:
        With xToSheet
            Set rTarg = .Cells(1, .Columns.Count).End(xlToLeft ).Offset(, 1)
        End With

Understood, thank you.

Now when I run, and select a destination folder with known txt files in it, it kicks me out of the loop and says no files found.
 
Upvote 0
Code:
Sub Data_Import()

Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Dim rTarg As Range
Dim xToSheet As Worksheet

Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"

If xFileDialog.Show = -1 Then
    xStrPath = xFileDialog.SelectedItems(1)
End If

If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "" Then xStrPath = xStrPath & ""
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Then
    MsgBox "No files found", vbInformation, "Kutools for Excel"
    Exit Sub
End If

Do While xFile <> ""
    xFiles.Add xFile, xFile
    xFile = Dir()
Loop

Set xToBook = ThisWorkbook
'set destination worksheet
Set xToSheet = xToBook.Sheets("Sheet1") 'Change me before running
Set rTarg = xToSheet.[A1]

If xFiles.Count > 0 Then
    For I = 1 To xFiles.Count
        Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
        xWb.Worksheets(1).Copy rTarg
        xWb.Close False
         With xToSheet
            Set rTarg = .Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1)
        End With
    Next
End If
End Sub
 
Upvote 0
Code:
Sub ImportTextFile()
Dim fName As String
fName = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If fName = "False" Then Exit Sub
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fName, _
        Destination:=Range("$A$3"))
        .Name = "sample"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 3
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        
    End With
    Range("AA1") = fName
    
    Columns("A:H").Select
    Columns("A:H").EntireColumn.AutoFit
    Range("A1").Select
        
End Sub

This is a chunk of code I have for a separate file. you can select 1 txt file and it puts it in the sheet.
Maybe it would be easier to edit this to loop and paste?
 
Upvote 0
Apologies for several posts, This is doing mostly what I want now.
I am unable to get it to paste the next imported file to the right of the last pasted imported file

Changing this line
Code:
"TEXT;" & myfiles(i), Destination:=Range("A" & Columns.Count).End(xlToRight).Offset(1, 3))
to
Code:
"TEXT;" & myfiles(i), Destination:=Range("A" & rows.Count).End(xlup).Offset(1, 0))
get it working but stays in the same columns and just adds to the bottom
tips?


Code:
Sub Data_Import()
Dim myfiles
Dim i As Integer
myfiles = Application.GetOpenFilename(filefilter:="txt Files (*.txt), *.txt", MultiSelect:=True)
If Not IsEmpty(myfiles) Then
    For i = LBound(myfiles) To UBound(myfiles)
         With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & myfiles(i), Destination:=Range("A" & Columns.Count).End(xlToRight).Offset(1, 3))
            .Name = "sample"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlOverwriteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 3
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = True
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    Next i
Else
    MsgBox "No File Selected"
End If
End Sub
 
Upvote 0
to find the last used column in row 1, you would use: Cells(1, Columns.Count).End(xlToLeft)

This is essentially saying select the first non-blank cell Left of cell in row 1, column XDF.

The OFFSET function moves the given range by (Rows, Columns)

So if you're wanting the first blank cell to the right of your existing data, set your destination using:
Code:
Destination:=Range.Cells(1, Columns.Count).End(xlToLeft).Offset(0,1)
 
Upvote 0
Doing this is unsuccessful.
It seems to have an issue remove the "A"
to find the last used column in row 1, you would use: Cells(1, Columns.Count).End(xlToLeft)

This is essentially saying select the first non-blank cell Left of cell in row 1, column XDF.

The OFFSET function moves the given range by (Rows, Columns)

So if you're wanting the first blank cell to the right of your existing data, set your destination using:
Code:
Destination:=Range.Cells(1, Columns.Count).End(xlToLeft).Offset(0,1)
 
Upvote 0

Forum statistics

Threads
1,213,562
Messages
6,114,326
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top