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
|