Re: Datenimport
18.09.2002 12:21:16
Thomas
Vielen dank Tim, damit kann ich schon was anfangen.
Doch ich bin ja faul *gr* :-)
Ich möchte das gern in dieses Macro einbauen:'basFunctions:
Option ExplicitPublic 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
Function GetDirectory(Optional Msg As String) 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
Function FileArray(strPath As String, strPattern As String)
Dim arrDateien()
Dim intCounter As Integer
Dim strDatei As String
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strDatei = Dir(strPath & strPattern)
Do While strDatei <> ""
intCounter = intCounter + 1
ReDim Preserve arrDateien(1 To intCounter)
arrDateien(intCounter) = strDatei
strDatei = Dir()
Loop
FileArray = arrDateien
End Function
'basMain:Option Explicit
Sub DatenImport()
Dim arrFiles As Variant
Dim intCounter As Integer, intRow As Integer
Dim strPath As String
Application.ScreenUpdating = False
strPath = GetDirectory("Bitte Pfad der Quelldateien auswählen:")
If strPath = "" Then Exit Sub
arrFiles = FileArray(strPath, "*.xls")
intRow = 1
For intCounter = 1 To UBound(arrFiles)
Workbooks.Open strPath & "\" & arrFiles(intCounter)
Range("A5:v25").Copy ThisWorkbook.Worksheets(1).Cells(intRow, 1)
ActiveWorkbook.Close savechanges:=False
intRow = intRow + 10
Next intCounter
End Sub
Da diesem Macro es egal ist wie die Datei heist ! Und ich nicht alle Dateien geöffnet haben muss....
Für deine Superschnelle hilfe nochmal vielen Dank !!
Thomas