excel importing data

B

bojan0810

Hi all!

I have this code

Sub Import2()
Dim qry As QueryTable
Dim FilNams As Variant
Dim FilNamCntr As Long
Dim strQryName As String
Dim LastRow As Long
Dim ContainerWB As Workbook
Dim msgString As String
FilNams = Application.GetOpenFilename(FileFilter:="Text Files (*.txt),*.txt", _
Title:="Select Textfile toImport", _
MultiSelect:=True)
'Check to see if any files were selected
If TypeName(FilNams) = "Boolean" Then
MsgBox "No Files Selected. Exiting Program."
Exit Sub
Else
'msgString = Join(FilNams, vbCr)
'MsgBox "FilNams is: " & msgString
End If
For FilNamCntr = LBound(FilNams) To UBound(FilNams)
FilNams(FilNamCntr) = "TEXT;" & FilNams(FilNamCntr)
Next FilNamCntr

'msgString = Join(FilNams, vbCr)
'MsgBox "FilNams is: " & msgString
For FilNamCntr = LBound(FilNams) To UBound(FilNams)
With ActiveSheet
On Error GoTo ErrorCatch:
'Append to previous data, if applicable
If .Range("A" & Rows.Count).End(xlUp).Row = 1 Then
LastRow = 1
Else
LastRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
End If
'MsgBox "LastRow value is:" & LastRow 'verification test
Set qry = .QueryTables.Add(Connection:=FilNams(FilNamCntr),_
Destination:=.Range("A" & LastRow))
With qry
.Name = "Filename"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileFixedColumnWidths = Array(14, 12, 11, 6, 6, 9, 7, 7)
.Refresh BackgroundQuery:=False
End With
End With
Next FilNamCntr
Exit Sub
ErrorCatch:
MsgBox "Unexpected Error. Type: " & Err.Description
End Sub

And its working great but, how to make that when you choose 2 files to import that second file is in second column(b) or if you have 3,4,5 etc files that every file is in other column (a b c d etc). And with this how to make not to seperate text from files into rows, that first file to import into A1 only, second file to B1, third to C1 and so on...

Thx
 
B

bojan0810

Can you post a download link so we can see a sample text file?



--

Garry



Free usenet access at http://www.eternal-september.org

Classic VB Users Regroup!

comp.lang.basic.visual.misc

microsoft.public.vb.general.discussion

It doesn't matter what is in text file. I need that macro code little fixedso any text from text file (.txt) is imported in only one cell. So first .txt file to import to A1 then second text file to B1 and so on. With this macro you choose what files to import. If you choose first and third file then it should be imported to A1 and B1. Only thing I need is to import .txt files to cells.
I don't wanna files to be imported seperated by rows likes its doing now.

So again if I have 3 .txt files(no matter about text in .txt) I wanna to import first .txt file to A1, second to B1 and third to C1. Code is resizing cells to text lengh so that isnt importan.

Thx
 
G

GS

Try...

Sub Import_TextFiles2Cols()
' Dumps the entire contents of selected text files into columns
Dim vFiles, sFile$, n&, lRow, lCol&

Const sFileTypes$ = "Text Files (*.txt),*.txt"
Const sTitle$ = "Select Textfile to Import"
vFiles = Application.GetOpenFilename(sFileTypes, , sTitle, , True)
'Check to see if any files were selected
If TypeName(vFiles) = "Boolean" Then _
MsgBox "No Files Selected. Exiting Program.": Exit Sub

On Error GoTo ErrHandler
For n = LBound(vFiles) To UBound(vFiles)
sFile = vFiles(n)
With ActiveSheet
'Distribute across columns
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(1, lCol) <> "" Then lCol = lCol + 1
'Find next row in target column
lRow = .Cells(.Rows.Count, lCol).End(xlUp).Row
If .Cells(lRow, lCol) <> "" Then lRow = lRow + 1
.Cells(lRow, lCol) = ReadTextFileContents(sFile)
End With 'ActiveSheet
Next 'n
Exit Sub

ErrHandler:
MsgBox "Unexpected Error. Type: " & Err.Description
End Sub

Function ReadTextFileContents$(Filename As String)
' Reads large amounts of data from a text file in one single step.
Dim iNum As Integer
On Error GoTo ErrHandler
iNum = FreeFile(): Open Filename For Input As #iNum
ReadTextFileContents = Space$(LOF(iNum))
ReadTextFileContents = Input(LOF(iNum), iNum)

ErrHandler:
Close #iNum: If Err Then Err.Raise Err.Number, , Err.Description
End Function 'ReadTextFileContents()

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

Oops.., typo!
Sub Import_TextFiles2Cols()
' Dumps the entire contents of selected text files into columns
Dim vFiles, sFile$, n&, lRow&, lCol&
Const sFileTypes$ = "Text Files (*.txt),*.txt"
Const sTitle$ = "Select Textfile to Import"
vFiles = Application.GetOpenFilename(sFileTypes, , sTitle, , True)
'Check to see if any files were selected
If TypeName(vFiles) = "Boolean" Then _
MsgBox "No Files Selected. Exiting Program.": Exit Sub

On Error GoTo ErrHandler
For n = LBound(vFiles) To UBound(vFiles)
sFile = vFiles(n)
With ActiveSheet
'Distribute across columns
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(1, lCol) <> "" Then lCol = lCol + 1
'Find next row in target column
lRow = .Cells(.Rows.Count, lCol).End(xlUp).Row
If .Cells(lRow, lCol) <> "" Then lRow = lRow + 1
.Cells(lRow, lCol) = ReadTextFileContents(sFile)
End With 'ActiveSheet
Next 'n
Exit Sub

ErrHandler:
MsgBox "Unexpected Error. Type: " & Err.Description
End Sub

Function ReadTextFileContents$(Filename As String)
' Reads large amounts of data from a text file in one single step.
Dim iNum As Integer
On Error GoTo ErrHandler
iNum = FreeFile(): Open Filename For Input As #iNum
ReadTextFileContents = Space$(LOF(iNum))
ReadTextFileContents = Input(LOF(iNum), iNum)

ErrHandler:
Close #iNum: If Err Then Err.Raise Err.Number, , Err.Description
End Function 'ReadTextFileContents()

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
B

bojan0810

Oh my. This worked perfectly as I needed. However. Only thing is missing that cells automaticly resize to biggest row in txt file. If you know to add that to that code, it would be amazing. But even without it, this is awesome. Thank you very much for this.
 
G

GS

Oh my. This worked perfectly as I needed. However. Only thing is
missing that cells automaticly resize to biggest row in txt file. If
you know to add that to that code, it would be amazing. But even
without it, this is awesome. Thank you very much for this.

You're welcome. I appreciate the feedback!

The files I tested were fairly large and Excel autofit the row height
to accomodate. Not saying this is what will happen with you, but
rowheight autofit has weird behavior and so no guarantee this will
work...

Change this line

.Cells(lRow, lCol) = ReadTextFileContents(sFile)

To

With .Cells(lRow, lCol)
.Value = ReadTextFileContents(sFile)
.EntireRow.Autofit
End With

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
B

bojan0810

Hmm... I am sorry to say that this didn't do anything. It stayed same as before.

Thanks again for reply
 
G

GS

Hmm... I am sorry to say that this didn't do anything. It stayed same
as before.

Thanks again for reply

Well.., I did say no guarantee! Try this...

Restore this line as before adding the With...End With block

.Cells(lRow, lCol) = ReadTextFileContents(sFile)

and add this line right after

.Rows(lRow).Autofit

...so your code now looks this way...

...
If .Cells(lRow, lCol) <> "" Then lRow = lRow + 1
.Cells(lRow, lCol) = ReadTextFileContents(sFile)
.Rows(lRow).Autofit
End With 'ActiveSheet

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
B

bojan0810

Thx for reply too, but its still same as before. I don't know if I am doing something wrong
 
G

GS

Yeah I know you said no guarantee lol. And with this new add its
still same

http://i44.tinypic.com/jice84.png

Look at this picture, as you can see, left is what I need and right
is what code gives.

Ok.., so you mean you want the *columns/rows* to autofit!!! To do that
in this scenario will require first setting ColumnWidth to some
arbitrary value before Excel will allow us to autofit the cols/rows.

Here's the entire code revised (and tested) to autofit each column...

Sub Import_TextFiles2Cols()
' Dumps the entire contents of selected text files into columns
Dim vFiles, sFile$, n&, lRow&, lCol&

Const sFileTypes$ = "Text Files (*.txt),*.txt"
Const sTitle$ = "Select Textfile to Import"
vFiles = Application.GetOpenFilename(sFileTypes, , sTitle, , True)
'Check to see if any files were selected
If TypeName(vFiles) = "Boolean" Then _
MsgBox "No Files Selected. Exiting Program.": Exit Sub

On Error GoTo ErrHandler
For n = LBound(vFiles) To UBound(vFiles)
sFile = vFiles(n)
With ActiveSheet
'Distribute across columns
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(1, lCol) <> "" Then lCol = lCol + 1
'Find next row in target column
lRow = .Cells(.Rows.Count, lCol).End(xlUp).Row
If .Cells(lRow, lCol) <> "" Then lRow = lRow + 1
With .Cells(lRow, lCol)
.Value = ReadTextFileContents(sFile)
'Set an arbitrary column width, then autofit
.ColumnWidth = 200
.EntireColumn.AutoFit: .EntireRow.AutoFit
End With '.Cells(lRow, lCol)
End With 'ActiveSheet
Next 'n
Exit Sub

ErrHandler:
MsgBox "Unexpected Error. Type: " & Err.Description
End Sub

Function ReadTextFileContents$(Filename As String)
' Reads large amounts of data from a text file in one single step.
Dim iNum As Integer
On Error GoTo ErrHandler
iNum = FreeFile(): Open Filename For Input As #iNum
ReadTextFileContents = Space$(LOF(iNum))
ReadTextFileContents = Input(LOF(iNum), iNum)

ErrHandler:
Close #iNum: If Err Then Err.Raise Err.Number, , Err.Description
End Function 'ReadTextFileContents()

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

Note that the col widths will also include the spaces occupied by the
non-printing CarriageReturn/LineFeed characters.

Note also that the RowHeight will be the highest number of text file
lines.

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
G

GS

You can eliminate 1 of the non-printing characters so the autofit col
width is tighter, by modifying the inner With...End With block as shown
below...

With .Cells(lRow, lCol)
.Value = Replace(ReadTextFileContents(sFile), vbCrLf, Chr(10))
'Set an arbitrary column width, then autofit
.ColumnWidth = 200
.EntireColumn.AutoFit: .EntireRow.AutoFit
End With '.Cells(lRow, lCol)

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
B

bojan0810

Oh my. This is exactly what I needed.

You are amazing.

Thank you very much.

I tested it with files what I have and it worked perfectly. Thank you
 
G

GS

Oh my. This is exactly what I needed.
You are amazing.

Thank you very much.

I tested it with files what I have and it worked perfectly. Thank you

You're welcome! Enjoy...

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top