AW: Daten aus Feld in Feld verschieben
18.12.2006 13:49:28
Fritz
Hallo Max,
etwas äahniches habe ich heute bereits im Forum beantwortet.
Hier der abgewandelte Code.
Es wird zuerst eine Liste der Ordner eingelesen, in dem dann anschließend nach der Datei "Kundenblatt.xls" gesucht wird. wird sie gefunden, werden 4 Zellen in eine neue (zuvor geöffnete) Datei geschrieben.
In diese neue Datei muss dieses Makro kopiert und ausgeführt werden.
Die Pfade müssen ebenfalls noch angepaßt werden.
Gruß
Fritz
Option Explicit
Declare
Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare
Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Declare
Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const MAX_PATH = 260
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_COMPRESSED = &H800
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Sub xx()
Dim I&, J&, LZ&
Dim FoundFileNames() As String
Dim Ws1 As Worksheet
Dim WbTmp As Workbook
Dim WsTmp As Worksheet
Dim hFind&, hFile&, nFile&
Dim FD As WIN32_FIND_DATA
Dim PathName$, Pattern$
PathName = "D:\temp\herber\" 'Pfadname der Excel-Dateien
Pattern = "*.xls" ' Dateiendung
Set Ws1 = ActiveWorkbook.ActiveSheet
LZ = Ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
'Alle Excel-Dateien ermitteln
ReDim FoundFileNames(0)
hFile = FindFirstFile(PathName & Pattern, FD)
If hFile > 0 Then
FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
Do
nFile = FindNextFile(hFile, FD)
If nFile > 0 Then
FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
End If
Loop While nFile <> 0
End If
FindClose hFile
'Verarbeitung starten
For I = 0 To UBound(FoundFileNames) - 1
Set WbTmp = Workbooks.Open(FoundFileNames(I))
Set WsTmp = WbTmp.Sheets(1)
For J = 1 To 7
Ws1.Cells(LZ + 1, J) = WsTmp.Cells(J, 2)
Next
Set WsTmp = Nothing
WbTmp.Close
LZ = LZ + 1
Next
End Sub
Sub YY()
Dim I&, J&, LZ&
Dim FoundFileNames() As String
Dim Ws1 As Worksheet
Dim WbTmp As Workbook
Dim WsTmp As Worksheet
Dim hFind&, hFile&, nFile&
Dim FD As WIN32_FIND_DATA
Dim PathName$, Pattern$
PathName = "D:\temp\Kunden" 'Pfadname der Excel-Dateien
Pattern = "*.*" ' Dateiendung
Set Ws1 = ActiveWorkbook.ActiveSheet
LZ = Ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
'Alle Ordner in "Kunden" ermitteln
ReDim FoundFileNames(0)
hFile = FindFirstFile(PathName & Pattern, FD)
If hFile > 0 Then
If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If ClearFileName(FD.cFileName) <> "." And ClearFileName(FD.cFileName) <> ".." Then
FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName) & "\"
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
End If
End If
Do
nFile = FindNextFile(hFile, FD)
If nFile > 0 Then
If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
If ClearFileName(FD.cFileName) <> "." And ClearFileName(FD.cFileName) <> ".." Then
FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName) & "\"
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
End If
End If
End If
Loop While nFile <> 0
End If
FindClose hFile
'Verarbeitung starten
Pattern = "Kundenblatt.xls"
For I = 0 To UBound(FoundFileNames) - 1
' MsgBox (FoundFileNames(I))
hFile = FindFirstFile(FoundFileNames(I) & Pattern, FD)
If hFile > 0 Then
Set WbTmp = Workbooks.Open(FoundFileNames(I))
Set WsTmp = WbTmp.Sheets(1)
For J = 1 To 4
Ws1.Cells(LZ + 1, J) = WsTmp.Cells(2, J) 'Zellen B1,B2,B3,B4 in neue Tabelle
Next
End If
Set WsTmp = Nothing
WbTmp.Close
LZ = LZ + 1
Next
End Sub
Function ClearFileName(CDat)
Dim X&
X = InStr(1, CDat, Chr$(0))
If X > 0 Then
ClearFileName = Trim$(Left$(CDat, X - 1))
Exit Function
End If
ClearFileName = ""
End Function