|
hallo leute,
Ich versuche alle csv dateien , die in einem Ordner sind zu öffnen, dann den Inhalt einer Zelle dieser Datei in einer tabelle zu kopieren. leider klappt es nicht und es wird nur einen bezug fehler angezeigt. Ich habe den Code mit xls datei probiert und es hat gekpplat. Hier ist mein Code
Option Explicit
Const zielCopy As String = "Tabelle1" 'tabelle wo es kopiert wird
Const ziel1 As String = "A6" 'zelle von der man den inhalt kopiert
Public quellecopy As String ' name der tabelle wo man etwas kopieren will
Sub DateienAuflisten()
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
Dim strDir As String
With ThisWorkbook.Worksheets(zielCopy)
.Rows("2:" & .Rows.Count).ClearContents
End With
Set objFileSystem = CreateObject("scripting.FileSystemObject")
strDir = ThisWorkbook.Path
Set objVerzeichnis = objFileSystem.GetFolder(strDir)
Set objDateienliste = objVerzeichnis.Files
For Each objDatei In objDateienliste 'auflisten der name von allen dateien
If Not objDatei Is Nothing And Right(objDatei.Name, 4) = ".csv" Then 'nur csv datei
quellecopy = objDatei.Name
dirInfo objVerzeichnis, "*.csv*" 'funktionsaufruf für die extraktion und speicherung
End If
Next objDatei
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim strFormula As String
Dim lngLastRow As Long
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
If Left(varTMP.Name, 1) <> "~" Then
With ThisWorkbook.Worksheets(zielCopy)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
With .Cells(lngLastRow, 1)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
quellecopy & "'!" & ziel1
.Value = .Value
End With
End With
End If
End If
Next
' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read" vorgegeben
' Dann durchsuche auch alle Unterordner
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
End Sub
gruß Patrick
|