kannst mal testen ob es so geht.
30.07.2010 12:05:02
Tino
Hallo,
ich gehe mal davon aus das die einzelnen Tabellen nicht in irgendeiner Form geschützt sind.
In ListeSH = Array("Tabelle1", "Tabelle3"),
Kannst Du die Tabellen entsprechend eintragen die bestehen bleiben sollen.
Gestartet wird mit der Prozedur 'Bereinigen'.
kommt als Code in Modul3
Option Explicit
Sub ListFilesInFolder(FileArray, SourceFolderName As String, Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False, Optional LCount As Long = 0)
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Status As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(SourceFolderName) Then
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.Files
If LCase(FileItem) Like LCase(DateiFormat) Then
Redim Preserve FileArray(LCount)
FileArray(LCount) = FileItem
LCount = LCount + 1
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder FileArray, SubFolder.Path, DateiFormat, IncludeSubfolders, LCount
Next SubFolder
End If
Else
MsgBox "Ordner nicht gefunden!", vbCritical
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
kommt als Code in Modul2
Option Explicit
Private Declare Function MoveWindow Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
ByVal lpStr1 As String, _
ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
ByVal pList As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassname As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private s_BrowseInitDir As String
Private Function BrowseCallback( _
ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If uMsg = &H1 Then
Call SendMessage(hwnd, &H466, ByVal 1&, ByVal s_BrowseInitDir)
Call CenterDialog(hwnd)
End If
BrowseCallback = 0
End Function
Private Function FuncCallback(ByVal nParam As Long) As Long
FuncCallback = nParam
End Function
Private Sub CenterDialog(ByVal hwnd As Long)
Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(&H10)
ScrHeight = GetSystemMetrics(&H11)
MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
(ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub
Public Function fncGetFolder( _
Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
Optional ByVal sPath As String = "C:\") As String
Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
If sPath Like "*.?" Or sPath Like "*.?" Then
sPath = Left$(sPath, InStrRev(sPath, "\"))
End If
If Dir(sPath, vbDirectory) = "" Then
sPath = ThisWorkbook.Path
End If
s_BrowseInitDir = sPath
With xl
.hwnd = FindWindow("XLMAIN", vbNullString)
.Root = 0
.Title = lstrcat(sMsg, "")
.Flags = &H1
.FName = FuncCallback(AddressOf BrowseCallback)
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim$(FolderName)
FolderName = Left$(FolderName, Len(FolderName) - 1)
End If
fncGetFolder = FolderName
End Function
kommt als Code in Modul5
Option Explicit
Sub EventAusAn(Zustand As Boolean, Optional strTxTStatusbar$)
Static ZustandAlt As Integer, oldStatusbar As Boolean
With Application
If Not Zustand Then
ZustandAlt = .Calculation
If strTxTStatusbar$ <> "" Then
oldStatusbar = .DisplayStatusBar
.DisplayStatusBar = True
.StatusBar = strTxTStatusbar$
End If
Else
If LCase(.StatusBar) <> "false" Then
.StatusBar = False
.DisplayStatusBar = oldStatusbar
End If
End If
.EnableEvents = Zustand
.ScreenUpdating = Zustand
.DisplayAlerts = Zustand
.Calculation = IIf(Zustand, ZustandAlt, xlCalculationManual)
End With
End Sub
kommt als Code in Modul1
Option Explicit
Sub Bereinigen()
Dim ArFile(), nCount&
Dim sOrdner$
Dim ListeSH
Dim ExWB As Workbook, ExSH As Object
sOrdner = fncGetFolder
If sOrdner = "" Then Exit Sub
ListFilesInFolder ArFile, sOrdner, "*.xls", False, nCount
If nCount > 0 Then
'liste der Tabellen die bestehen bleiben sollen, evt. anpassen
ListeSH = Array("Tabelle1", "Tabelle3")
EventAusAn False, "bitte warten..."
For nCount = Lbound(ArFile) To Ubound(ArFile)
Application.StatusBar = "bearbeite File " & nCount + 1 & " von " & Ubound(ArFile) + 1 & ", bitte warten..."
If Not ArFile(nCount) Like "*" & ThisWorkbook.Name Then
Set ExWB = Workbooks.Open(ArFile(nCount))
If Not ExWB Is Nothing Then
If Not ExWB.ReadOnly Then
For Each ExSH In ExWB.Sheets
With ExSH
On Error Resume Next
If Not IsNumeric(Application.Match(.Name, ListeSH, 0)) Then
.Delete
Else
.Range("L1", .Cells(1, .Columns.Count)).EntireColumn.Delete
.Range("A181", .Cells(.Rows.Count, 1)).EntireRow.Delete
End If
On Error GoTo 0
End With
Next ExSH
ExWB.Close Not ExWB.Saved
Else
ExWB.Close False
End If
End If
End If
Next nCount
EventAusAn True
End If
End Sub
Gruß Tino