Import Data

Hi,

I have this VBA macro which imports data from a text file.
I do not know exactly how to make it good.

I have two sheets, named <INDATA> <Drawing_list>

On sheet <Drawing_List> I made a command button with this code:

Private Sub CommandButton1_Click()
'
' Macro1 Macro
' Macro recorded 2/17/2008 by Hack
'

'
    
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;H:\MyPath\test.txt", _
        Destination:=Range("A1"))
        .Name = "test.txt"
        .FieldNames = True
        .RowNumbers = True
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(2)
        .Refresh BackgroundQuery:=False
    End With
End Sub

When I click it, it imports information from a textfile as you see.
Allthough the information is printed out on sheet <Drawing_List> where the button is.
I bet it has something to do with "With ActiveSheet" statement.
I want the data from the textfile to be prionted in sheet <INDATA>.

How?

And my second question is how can this macro import data from all *.txt files under a certain path and print out the result in sheet <INDATA>
In above case it's only one file.
Is it like:
"TEXT;H:\MyPath\*.txt", _
.Name = "*.txt"

My third question is relative paths. In my office we store project files in H:\Projectname\*.txt

Projectname differs, so how can I make above code to:
1. Read all text files in a specified fodler
2. Put that data after eachother in sheet called <INDATA>
3. Make the path to the specified folder "relative" due to project names are different

Thanx

This is liek my first attempt to modify the code above to my needs.

best regards

Hi au-s
This modified Andy Pope code may do the Trick

Sub Macro1()
     '
     ' Macro1 Macro
     ' Macro  recorded 15/05/2006 by Andy Pope
     '
    Dim strPath As String
    Dim strFile As String
   
    strPath = "H:\MyPath\"
    strFile = Dir(strPath & "*.txt")
    Do While strFile <> ""
        With ActiveWorkbook.Worksheets("INDATA")
            With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
                Destination:=.Cells(Rows.Count, 1).End(xlUp).Row)
             .Parent.Name = Replace(strFile, ".txt", "")
                .FieldNames = True
        .RowNumbers = True
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(2)
        .Refresh BackgroundQuery:=False

            End With
        End With
        strFile = Dir
     Loop
     
End Sub

Hi,

That is strange.
It runs okay if no text file is in that folder.
Allthough when a textfile is there it gives me runtime error 13.

When I search this rows output error
With .QueryTables.Add(Connection:="TEXT;" & strPath & strFile, _
Destination:=.Cells(Rows.Count, 1).End(xlUp).Row)

thanx for help Sir

Best Regards

You wont need

 strPath &

I'll have a close look this afternoon day as its 12:30pm here

This may be better
what the dilemiter?

Sub ptest()
    Dim b$, y$, p!, i$, k!, e
    b = "H:\MyPath\"
    k = ActiveWorkbook.Worksheets("INDATA").Cells(Rows.Count, 2).End(xlUp).Row
    ChDir b
    i = Dir("*.txt")
    Do While Len(i) > 0
        Open i For Input As #1

        Do Until EOF(1)
            p = 1
            Line Input #1, y
            With ActiveWorkbook.Worksheets("INDATA")
                For Each e In Split(y, ",")
                    .Cells(Rows.Count, 1).End(xlUp).Offset(k, p) = e
                    p = 1 + p
                Next
                k = k + 1
            End With
        Loop
        Close #1
        i = Dir
    Loop
End Sub

you will probally want to change this line

For Each e In Split(y, ",")

to

For Each e In Split(y, vbTab)

Thank you Sir.

That works okay. Very thankful for it.
If I may ask you one more thing. Relative path.
Right now the path needs to be exact. What if I want to make path such as:


..\..\Mypath
or
..\..\..\Mypath

So I can decide how relative it shall be. Is it possible?

And where can I put the data:

.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2)
.Refresh BackgroundQuery:=False

Thank you very much in advance.

I am begining to catch up a bit with the code now ..

one way

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO: hOwner As Long: pidlRoot As Long: pszDisplayName As String: lpszTitle As String: ulFlags As Long: lpfn As Long: lParam As Long: iImage As Long: End Type


Function DxfGetDirectory(Optional Msg) As String
Dim bInfo  As BROWSEINFO, path$, r&, x&, pos%
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Browse for a folder."
Else: bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo): path = Space$(512): r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0)): DxfGetDirectory = Left(path, pos - 1)
Else: DxfGetDirectory = ""
End If
End Function

Sub ptest()
    Dim b$, y$, p!, i$, k!, e
    b = DxfGetDirectory (Msg) &"\"
    k = ActiveWorkbook.Worksheets("INDATA").Cells(Rows.Count, 2).End(xlUp).Row
    ChDir b
    i = Dir("*.txt")
    Do While Len(i) > 0
        Open i For Input As #1

        Do Until EOF(1)
            p = 1
            Line Input #1, y
            With ActiveWorkbook.Worksheets("INDATA")
                For Each e In Split(y, ",")
                    .Cells(Rows.Count, 1).End(xlUp).Offset(k, p) = e
                    p = 1 + p
                Next
                k = k + 1
            End With
        Loop
        Close #1
        i = Dir
    Loop
End Sub

Do you only want 2 columns?

One column is okay. It gives me one error about comments on the first line. of your above code. Declare function
And that it overrite data all data.
Thank you Sir

if its one column, it should be spliting, you have to find the correct delimiter
either "," or vbtab or char(34) or " "
there will be a couple to chose from. you can look by opening the csv in notebook

Hi au-s
the top code must be the very first code up with option explicit

Allright, everytrhing works ...


To overright data ... how can I make that code to overrite exisiting imoport and make formatting look like this:
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2)
.Refresh BackgroundQuery:=False

All this formatting ... Where in the code shall that be placed ...

??
Sorry for so many questions

I really should test this stuff first
try this

Option Explicit
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO: hOwner As Long: pidlRoot As Long: pszDisplayName As String: lpszTitle As String: ulFlags As Long: lpfn As Long: lParam As Long: iImage As Long: End Type
Public msg

Function DxfGetDirectory(Optional msg) As String
Dim bInfo  As BROWSEINFO, path$, r&, x&, pos%
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Browse for a folder."
Else: bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo): path = Space$(512): r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0)): DxfGetDirectory = Left(path, pos - 1)
Else: DxfGetDirectory = ""
End If
End Function



Private Sub CommandButton1_Click()
    Dim b$, y$, p!, i$, k!, e
    b = DxfGetDirectory(msg) & "\"
    k = ActiveWorkbook.Worksheets("INDATA").Cells(Rows.Count, 2).End(xlUp).Row
    ChDir b
    i = Dir("*.txt")
    Do While Len(i) > 0
        Open i For Input As #1

        Do Until EOF(1)
            p = 1
            Line Input #1, y
            With ActiveWorkbook.Worksheets("INDATA")
                For Each e In Split(y, vbTab)
                    .Cells(Rows.Count, 1).End(xlUp).Offset(k, p) = e
                    p = 1 + p
                Next
                k = k + 1
            End With
        Loop
        Close #1
        i = Dir
    Loop
End Sub

hey au-s
we must be getting close how did it go or do we need a final fine tune?

Hey au-s
replace

 k = ActiveWorkbook.Worksheets("INDATA").Cells(Rows.Count, 2).End(xlUp).Row

with

     ActiveWorkbook.Worksheets("INDATA").Cells.ClearContents
    k =1

should do it

welcome the build in help files are good.In the code just highlight the word cells and press"F1" for an explaination

Hi again,

Do not know why it happens but it does. This macro is okay allthough when I run

Private Sub CommandButton1_Click()

I often get the copy (as text) in the "data2" sheet of ALL Private Subs coded. So the whole code is typed out in data2 and not the data from the text files.
So, it ignores the data in the textfiles and types the code instead in that sheet "data2".

Sometimes when I deactivate macros and then activate them again it works.
But mostly I need to do it all over again in a new workbook from scratch.

I have to say that the Private Sub CommandButton1_Click() macro is in a Worksheet called Import.
The Function you gave me with Option Explicit is as a module, Module1 so it is not in the Worksheet code but as a module.

I have included my Worksheet ... It is all in Swedish But I think you will get the picture.
Go to sheet "SkapaRitnings..." and look for
Private Sub CommandButton1_Click()
That is the button which has IMPORT FRAN CAD.

Thanx

PS
If I remove Options Explicit, it usually start working.

Hey au-s
I dont like to dont load any this over 20k on the wireless network
So i had to wait till I had the glass wire connection to down load 134k

anyway try this
have moved the code back to the module and the button now call that sub

It still prints out the whole code....
hehe ..

Thing is that if I make some cosmetic or code change to it, it behaves strange ...

prints out the whole code?
what do you mean?

I'll have to down load tomorrow and have a closer look
so instead of printin the text file to the "INDATA" sheet it copies from the "data2".
O mr au-s what have you dont

just a famous add . it wont be much .. knew I should had down loaded a copy today.
any who I will have a geeek tomorrow and reply

with the changes i made this morning?

the posted code looks OK
I'll take a closer look tomorrow. Its strange its reading the sheet module code to the work sheet?
there is heap we can do to make it run smoth for example remove the "select" and replace then with "With" syntax ect...

hHi au-s
try this code for module one

Option Explicit
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO: hOwner As Long: pidlRoot As Long: pszDisplayName As String: lpszTitle As String: ulFlags As Long: lpfn As Long: lParam As Long: iImage As Long: End Type
Public msg


Function DxfGetDirectory(Optional msg) As String
Dim bInfo  As BROWSEINFO, path$, r&, x&, pos%
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "VÄLJ PROJEKTMAPP!"
Else: bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo): path = Space$(512): r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0)): DxfGetDirectory = Left(path, pos - 1)
Else: DxfGetDirectory = "VÄLJ PROJEKTMAPP!"
End If
End Function

 Sub thisOne()
    Dim b$, y$, p!, i$, k!, e
    b = DxfGetDirectory(msg) ' & "\A\Admin-IT\Attribut\Export\Förteckningar\Ritnings\"
         ActiveWorkbook.Worksheets("data2").Cells.ClearContents
    k = 1
    ChDir b
    i = Dir("*.txt")
    Do While Len(i) > 0
        Open i For Input As #1

        Do Until EOF(1)
            p = 1
            Line Input #1, y
            With ActiveWorkbook.Worksheets("data2")
                For Each e In Split(y, vbTab)
                    .Cells(Rows.Count, 1).End(xlUp).Offset(k, p) = e
                    p = 1 + p
                Next
                k = k + 1
            End With
        Loop
        Close #1
        i = Dir
    Loop
    ' Delete blank Rows see module 2
    DeleteBlankRows
End Sub

dont know what this bit is about but I removed Rem

' & "\A\Admin-IT\Attribut\Export\Förteckningar\Ritnings\"

and
change this

Function DxfGetDirectory(Optional msg) As String
Dim bInfo  As BROWSEINFO, path$, r&, x&, pos%
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "VÄLJ PROJEKTMAPP!"
Else: bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo): path = Space$(512): r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0)): DxfGetDirectory = Left(path, pos - 1)
Else: DxfGetDirectory =""   ' This bit back to "" what is "VÄLJ PROJEKTMAPP!"
End If
End Function

what is "VÄLJ PROJEKTMAPP!"
I have a copy now so lets fine tune away

Hi au-s
We can change the way you pick the path .If that is the case maybe a combobox in a userform will be better?

Hi au-s
Have a go at creating a userform and add a combobox ect..
I'll help you work with what you come up with

Right,

But can' the path just be \Admin-IT\Attribut\Export\Förteckningar\Ritnings\
Does the path needs to be absolute?

I mean if you have:

Private Const ExportPath  As String = "Admin-IT\Attribut\Export\Förteckningar\Ritnings\"

Then the above code is the path.
The projects absolute path is:
U:\j-k-l\Lproject

Path to thextfiels is:
U:\j-k-l\Lproject\A\Admin-IT\Attribut\Export\Förteckningar\Ritnings\*.txt

Path to excelfile is:
U:\j-k-l\Lproject\A\Dokument\08_Forteckningar\exelfile.xls


Second solution is if I make a comboBox I do not know exactly how I can solve it with a drop down.
The best solution then is to have a TextBox where you type the first path as a string and then the rest of the path is just added in the function?

I made something like that:

Option Explicit
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO: hOwner As Long: pidlRoot As Long: pszDisplayName As String: lpszTitle As String: ulFlags As Long: lpfn As Long: lParam As Long: iImage As Long: End Type
Private Const ExportPath As String = "\A\Admin-IT\Attribut\Export\Förteckningar\Ritnings\"
Public msg


Function DxfGetDirectory(Optional msg) As String
Dim bInfo  As BROWSEINFO, path$, r&, x&, pos%
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Browse for folder."
Else: bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo): path = Space$(512): r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0)): DxfGetDirectory = Left(path, pos - 1)
Else: DxfGetDirectory = ""
End If
End Function

 Sub thisOne()
     Dim AbsolutExportRitningsfrtPath As String
    
    AbsolutExportRitningsfrtPath = DxfGetDirectory(msg) & ExportPath
    Dim b$, y$, p!, i$, k!, e
   
         ActiveWorkbook.Worksheets("data2").Cells.ClearContents
         k = 1
    ChDir AbsolutExportRitningsfrtPath
    i = Dir("*.txt")
    Do While Len(i) > 0
        Open i For Input As #1

        Do Until EOF(1)
            p = 1
            Line Input #1, y
            With ActiveWorkbook.Worksheets("data2")
                For Each e In Split(y, vbTab)
                    .Cells(Rows.Count, 1).End(xlUp).Offset(k, p) = e
                    p = 1 + p
                Next
                k = k + 1
            End With
        Loop
        Close #1
        i = Dir
    Loop
    ' Delete blank Rows see module 2
    DeleteBlankRows
    MsgBox ("Importen är KLAR!")
End Sub

I made changes to
added Private Const ExportPath
and
in the Sub code:
Dim AbsolutExportRitningsfrtPath As String


Look also on the Sub code if it is correct ...

Seems to work now as well but it copies the code sometimes I have noticed again.

hi au-s
what I was thinking was replace this with

 b = DxfGetDirectory(msg) ' & "\A\Admin-IT\Attribut\Export\Förteckningar\Ritnings\"
         ActiveWorkbook.Worksheets("data2").Cells.ClearContents
    k = 1

with

userform1.show
b = "U:\j-k-l\Lproject\" & combox1.value & \"
         ActiveWorkbook.Worksheets("data2").Cells.ClearContents
 unload userform1
   k = 1

and userform code

Private Sub CommandButton1_Click()

UserForm1.Hide
End Sub

Private Sub UserForm_Initialize()
With ComboBox1
.List = Array("Admin-IT\Attribut\Export\Förteckningar\Ritnings\", "what ever", "and again", "more stuff", "u")
End With
End Sub

if you are use changing folders

thats ONLY if the first part of the path is constant
if its the second part thats constant you will have to revert to the original code
and complete the whole path
you just cant pick one bit unless it the end

with the original code I couldnt make it do the same as you

No not at all
As long as you have something to work with and are willing to have a go we can go down in history as the longest post ever! but we have a long long long way to go before that.
I like to solve the puzzles

yes maybe, but you would have to pull up short of the full path! one folder to many and you will create an error as the path wont exist
worth a try..