Fehler beim Kopieren von Daten aus anderen Dateien
04.02.2016 16:44:51
Daten
ich suche nach einer Lösung für folgendes Problem:
Ich möchte gerne die Daten aus allen Excel-Mappen (Endung .xlsm) in einem bestimmten Ordner, jeweils von Blatt1 ("Input"), Bereich B17:F49, kopieren und untereinander auf einem neuen Blatt in die aktuelle Mappe einfügen.
Bisher habe ich folgenden Code, bei dem ich zwar keine Fehlermeldung erhalte, allerdings werden auch keine Daten kopiert - es wird nur ein leeres Blatt neu eingefügt.
Kann mir jemand sagen, was hier der Fehler ist ?
Mein Code:
Sub FindFiles()
Dim objFile As Object
Dim objFolder As Object
Dim objFSO As Object
Dim varNewSheet As Worksheet
Dim varPath As String
Dim varRowCount As Integer
Dim varSheet As Worksheet
Dim varWorkbook As Workbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
varPath = "C:\Users\mo\Desktop\Test-Import\"
Set objFolder = objFSO.GetFolder(varPath)
Set varNewSheet = Worksheets.Add
For Each objFile In objFolder.Files
varRowCount = varNewSheet.UsedRange.Rows.Count
If (objFile.Type = "Microsoft Excel Worksheet") Then
Set varWorkbook = Application.Workbooks.Open(varPath & objFile.Name)
Set varSheet = varWorkbook.Sheets(1)
varSheet.Range("B17:F49").Copy
varNewSheet.Activate
If varRowCount = 1 Then
varNewSheet.Cells(1, 1).Value = objFile.Name
varNewSheet.Cells(varRowCount + 1, 1).Select
Else
varNewSheet.Cells(varRowCount + 1, 1).Value = objFile.Name
varNewSheet.Cells(varRowCount + 2, 1).Select
End If
ActiveSheet.Paste
Application.DisplayAlerts = False
varWorkbook.Close
End If
Next
Application.DisplayAlerts = True
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Sub
LG,
Tanja