Hallo,

ich benötige für folgendes eure Hilfe.

1. Im ersten Teil des Programms ´füge ich die Überschriften aus einem Excel File jetzt hätte ich gerne, dass im zweiten Schritt sich das Programm die Überschrift merkt und in den nachfolgenden Excel Files den Wert rechts neben der "Überschrift" einfügt.

2. Kann man das Programm schneller machen?

Option Explicit

Sub DatenImport()
Application.ScreenUpdating = 0
 
    'dim
        Dim FileList$(), sPath$
        Dim ErrorMessage$
        Dim WB1 As Object, WB2 As Object
        Dim CRange As Range, PRange As Range
        Dim I&, J&
        Dim WFN$
        Dim intzeile&
     
       
       
   

'dim
Dim filename As Variant

'set
filename = Application.GetOpenFilename _
("Micrsoft Excel-Dateien (*.xl*),*.xl*")
If filename = False Then Exit Sub

'aktuelles workbook speichern, neues öffnen

Anzahlueberschriften = InputBox("anzahl")

For I = 1 To 2

 aa = InputBox("Wählen Sie eine Spalte aus")
bb = InputBox("Wählen Sie eine Zeile aus")

Set WB1 = ActiveWorkbook
Set WB2 = Workbooks.Open(filename)
Set CRange = WB2.Sheets(1).Range(aa & bb)
Set PRange = WB1.Sheets(1).Cells(1, 1 + I)

'kopieren

CRange.Copy
PRange.PasteSpecial
'schließen
WB2.Close (False)
'WB1.Close (True)
Application.ScreenUpdating = 1

Next
      Stop
       
       
       
    'set
        WFN = ThisWorkbook.FullName
        sPath = "C:\Documents and Settings\tfcese\Desktop\Ergebnis"
       
        ErrorMessage$ = fListFiles(FileList, sPath, False, "*", "xl*")
        If ErrorMessage$ <> "" Then
            MsgBox ErrorMessage$
            Exit Sub
        End If
       
        qa = InputBox("Spalte")
        intzeile = InputBox("Zeile")
       
    'aktuelles workbook speichern, neues öffnen
        Set WB1 = ActiveWorkbook
        ReDim ADat(UBound(FileList), 1)
        For I = LBound(FileList) + 1 To UBound(FileList)
               
            If Not FileList(I) = WFN Then
                Set WB2 = Workbooks.Open(FileList(I))
                With WB1.Sheets(1)
                .Cells(I + 1 - J, 3).Value = WB2.Sheets(1).Range(qa & intzeile).Value
                .Cells(I + 1 - J, 1).Value = FileList(I)
                End With
                WB2.Close (False)
            Else: J = J + 1
            End If
           
        Next
       
Application.ScreenUpdating = 1
End Sub

Function fListFiles( _
ByRef List() As String, _
ByVal sPath As String, _
Optional ByVal bSubfolders As Boolean = False, _
Optional ByVal sFilenameFilter As String = "*", _
Optional ByVal sExtensionFilter As String = "*" _
) As String
   
    'dim
        Dim oFS As Object
        Dim OFolder As Object
        Dim oSubfolder As Object
        Dim oFile As Object
       
    'arrays
        Dim Count As Long
       
    'set
        fListFiles = "No Files found"
        If FolderDoesntExist(sPath) Then
            fListFiles = "Folder doesn't exist"
            Exit Function
        End If
       
        Set oFS = CreateObject("Scripting.FileSystemObject")
        Set OFolder = oFS.GetFolder(sPath)

    'search
        For Each oFile In OFolder.Files
            If oFile.Name Like sFilenameFilter & "." & sExtensionFilter Then
       
                ReDim Preserve List(Count)
                List(Count) = oFile.Path
                Count = Count + 1
                fListFiles = vbNullString
               
            End If
        Next
       
        If bSubfolders Then
            For Each oSubfolder In OFolder.SubFolders
                For Each oFile In oSubfolder.Files
               
                    If oFile.Name Like sFilenameFilter & "." & sExtensionFilter Then
                               
                        ReDim Preserve List(Count)
                        List(Count) = oFile.Path
                        Count = Count + 1
                        fListFiles = vbNullString

                    End If
                   
                Next
            Next
        End If
   
    'clear
        Set oFS = Nothing
        Set oFile = Nothing
        Set oSubfolder = Nothing
        Set OFolder = Nothing
  
End Function

Function FolderDoesntExist(sPath$) As Boolean
   
    Dim OFolder As Object
    Dim oFS As Object
   
    On Error GoTo FolderDoesNotExist
    Set oFS = CreateObject("Scripting.FileSystemObject")
    FolderDoesntExist = 0
    Set OFolder = oFS.GetFolder(sPath)
    Set oFS = Nothing
    Set OFolder = Nothing
    Exit Function

FolderDoesNotExist:
    Set oFS = Nothing
    Set OFolder = Nothing
    FolderDoesntExist = 1
End Function