Daten einlesen

[Krause-r-h]

Hallo alle miteinander

Ich hab mal wieder ein kleines Problem mit dem einlesen von Dateien.
In der Angehängten Datei "Würfelliste_Einlesen" sollen 5 einzelne Zellen aus mehreren Dateien (z.B. 11. Blatt . xlsx - 13. Blatt . xlsx ) eingelesen werden .Passt auch so weit.
Aber ich möchte diese in einer Formatierten oder Inteligenten Tabelle Eingelesen werden und das Passt nicht.
Er schreibt die Werte immer ans Tabellenende Hmm .  

Könnte ihr mir mal bitte weiterhelfen?? und mir im Code reinschreiben wo es nicht past .
Ich gebe es zu den vba-code naja hab ich nicht selbst Geschrieben nur verändert.

Vielen Lieben Dank im vorraus

[Frogger1986]

Du möchtest also die Daten erweitern und nicht immer neu einlesen?

[Krause-r-h]

Du möchtest also die Daten erweitern und nicht immer neu einlesen?

 
Hallo [b]Frogger [/b]
Ja genau die Tabelle wird ja vor dem neu Einlesen erst gelöscht und mit neuen Dateien neu eingelesen
 ich hab es auch schon mit einer anderen Variante probiert aber das war nicht so gut wie mit dieser Variante
Lg aus Lauenburg

[Frogger1986]

In ein Modul und im Tabellenblatt, in das die Daten eingefügt werden, via button aufrufen! 
Vorher den Dateipfad anpassen!

Code:

Option Explicit
Sub DateienAuflisten()

Dim lngZeile As Long
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
Dim objDatei As Object
Dim Dateipfad As String

Dateipfad = ThisWorkbook.Path 'Passend ab?ndern!

Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(Dateipfad)
Set objDateienliste = objVerzeichnis.Files

lngZeile = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

For Each objDatei In objDateienliste
    If Not objDatei Is Nothing And InStr(objDatei, ".xlsx") And objDatei <> ThisWorkbook.Name Then
       With ThisWorkbook.ActiveSheet
           .Cells(lngZeile, 1) = objDatei.Name
           .Cells(lngZeile, 2).FormulaLocal = "='" & Dateipfad & "\[" & .Cells(lngZeile, 1).Value & "]BETONPR?FUNG leer'!$H$1"
           .Cells(lngZeile, 3).FormulaLocal = "='" & Dateipfad & "\[" & .Cells(lngZeile, 1).Value & "]BETONPR?FUNG leer'!$N$6"
           .Cells(lngZeile, 4).FormulaLocal = "='" & Dateipfad & "\[" & .Cells(lngZeile, 1).Value & "]BETONPR?FUNG leer'!$V$6"
           .Cells(lngZeile, 5).FormulaLocal = "='" & Dateipfad & "\[" & .Cells(lngZeile, 1).Value & "]BETONPR?FUNG leer'!$AD$6"
           .Cells(lngZeile, 6).FormulaLocal = "='" & Dateipfad & "\[" & .Cells(lngZeile, 1).Value & "]BETONPR?FUNG leer'!$K$7"
       End With
   
       lngZeile = lngZeile + 1
   
    End If
Next objDatei

Application.ScreenUpdating = False
   Activesheet.Range("B2:F" & lngZeile).Copy
   Activesheet.Range("B2:F" & lngZeile).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
   Application.CutCopyMode = False
    Activesheet.Range("A1").Select
Application.ScreenUpdating = True

End Sub

[Krause-r-h]

Danke für deine Hilfe ja wenn ich den Code so sehe müsste es klappen 
Muss jetzt erst mal zum essen eigentlich zu warm ...  .
Ich danke dir erst mal und teste es heute noch aus
Viele Grüße aus Lauenburg
Ronny