txt.-Datei per UF mit getdirectory
12.10.2006 21:29:35
Wolfgang
einmal mehr benötige ich die Hilfe des Forums; Über eine UF würde ich gerne diverse Textdateien "ansteuern" (alle mit nicht feststehenden Namen) und die Daten dann in ein jeweils auszuwählendes Tabellenblatt und eine jeweils auszuwählende Spalte einfügen. Ich denke mir, dass die UF mehrere Sektionen enthalten könnte und jede Sektion a) die Möglichkeit der Anwahl der Textdatei (hierzu habe ich einen evtl. denkbaren Code in Recherche entdeckt und untenstehend eingefügt), b) ein Auswahlfenster für die anzusteuernde Tabelle und C) ein Auswahlfenster für die auszuwählende Spalte, in die die Daten ab Zeile 1 hineinkopiert werden sollen. Wie könnten die Codes umgestellt werden, dass ein Ansteuern nach vorgenannten Modalitäten erfolgen kann? - Herzlichen Dank schon jetzt wieder Allen für die Rückmeldung.
Gruß
Wolfgang
Hier der Code für getdirectory:
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
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
Sub DirAuswahl()
Dim msg As String
msg = "Wählen Sie bitte einen Ordner aus:"
MsgBox getdirectory(msg)
End Sub
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
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))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function
Hier der Code für den Import der Textdatei:
Sub Import1()
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Dokumente und Einstellungen\A\Desktop\KundeA.txt", _
Destination:=Range("A1"))
.Name = "KundeA"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(9, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, _
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub