Hallo zusammen,
ich habe folgendes Problem. Beim Wechsel auf Excel 2007 funktioniert folgendes Makro nicht mehr. Es erscheint die Meldung "400". Kann mir vielleicht einer weiterhelfen was geändert warden muss?
Danke und Gruß
------------------------------------------------------------------------------------------
Option Explicit
Sub Daten_kopieren()
Dim Pfad As String, Dateiname As String, iColumn As Long
'Select Folder where project sheets are
Pfad = "xxxx"
Dateiname = Dir(Pfad & "*.xls")
'alten Inhalt löschen
ThisWorkbook.Sheets("CollectedData").Range("C2:BZ27").ClearContents
ThisWorkbook.Sheets("CollectedData").Range("A32:E132").ClearContents
Do While Dateiname <> ""
Application.ScreenUpdating = False
Workbooks.Open Filename:=Pfad & Dateiname
'Erste freie Spalte finden
iColumn = ThisWorkbook.Sheets("CollectedData").Cells(2, Columns.Count).End(xlToLeft).Offset(0, 1).Column
'Projekttitel kopieren
Workbooks(Dateiname).Sheets("Overview").Range("H2").Copy
ThisWorkbook.Sheets("CollectedData").Cells(2, iColumn).PasteSpecial (xlPasteValues)
'Standort kopieren
Workbooks(Dateiname).Sheets("Overview").Range("C16").Copy
ThisWorkbook.Sheets("CollectedData").Cells(27, iColumn).PasteSpecial (xlPasteValues)
'Planned budgets
Workbooks(Dateiname).Sheets("Overview").Range("T24:T35").Copy
ThisWorkbook.Sheets("CollectedData").Cells(3, iColumn).PasteSpecial (xlPasteValues)
'Actual budgets
Workbooks(Dateiname).Sheets("Overview").Range("U24:U35").Copy
ThisWorkbook.Sheets("CollectedData").Cells(15, iColumn).PasteSpecial (xlPasteValues)
Workbooks(Dateiname).Close
Dateiname = Dir()
'Vorbereiten für Fabriksortierung(Füllen der Hilfstabelle)
Dim iRow As Long
iRow = ThisWorkbook.Sheets("CollectedData").Range("A65536").End(xlUp).Offset(1, 0).Row
ThisWorkbook.Sheets("CollectedData").Cells(2, iColumn).Copy
ThisWorkbook.Sheets("CollectedData").Cells(iRow, 3).PasteSpecial (xlPasteValues)
ThisWorkbook.Sheets("CollectedData").Cells(27, iColumn).Copy
ThisWorkbook.Sheets("CollectedData").Cells(iRow, 1).PasteSpecial (xlPasteValues)
ThisWorkbook.Sheets("CollectedData").Cells(14, iColumn).Copy
ThisWorkbook.Sheets("CollectedData").Cells(iRow, 4).PasteSpecial (xlPasteValues)
ThisWorkbook.Sheets("CollectedData").Cells(26, iColumn).Copy
ThisWorkbook.Sheets("CollectedData").Cells(iRow, 5).PasteSpecial (xlPasteValues)
Loop
'Sortieren der Fabriken (In Hilsftabelle
Range("A32:E132").Select
Selection.Sort Key1:=Range("A32"), Order1:=xlAscending, Key2:=Range("D32"), Order2:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ThisWorkbook.Sheets("Overview").Select
Application.ScreenUpdating = True
End Sub |