Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1168to1172
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Makro

VBA Makro
Sascha
Guten Morgen zusammen,
ich hätte da mal ein Anliegen und hoffe hier kann mir geholen werden!
folgender Sachverhalt:
ich habe 30 Dateien die identisch aufgebaut sind. Alle diese Dateien sollen nacheinander oder wegen mir auch gleichzeitig geöffnet werden, dann sollen einzelne Reiter und bestimmte Zeilen der übriggebliebenen Reiter gelöscht werden, dann speichern und fertig.
sollte doch eigentlich nicht zu schwer sein, oder?
Danke und gruß
Sascha

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: VBA Makro
30.07.2010 10:55:21
selli
hallo sascha,
antwort auf deine frage: ist auch nicht so schwer.
gruß selli
AW: VBA Makro
30.07.2010 10:58:53
Sascha
Sorry, aber kommt da jetzt noch was Produktives?
AW: VBA Makro
30.07.2010 11:13:52
selli
sorry, aber von mir so nicht.
AW: VBA Makro
30.07.2010 11:21:25
Sascha
Zum Glück gibt es hier noch andere Forumsmitglieder, die nicht nur den Besserwisser raushängen lassen wollen, sondern wirklich willens sind zu helfen...
AW: VBA Makro
30.07.2010 10:58:30
Klaus
Hi Sascha,
abei mal Makros dafür. Ich gehe davon aus, dass die Reiter alle identisch benannt sind.
Pfadangaben, zu löschende Tabellen usw. musst du natürlich anpassen. In der Sub "abarbeiten" kannst du dir bestimt eine Schleife um die Aufrufe herum basteln (lassen).
Sub OpenIt(myPfad As String, myFile As String)
Workbooks.Open (myPfad & "\" & myFile)
'geöffnetes Workbook ist automatisch das aktive sheet!
Sheets("Tabelle1").Delete
Sheets("Tabelle2").Range("A1").ClearContents
ActiveWorkbook.Close
End Sub
Sub Abarbeiten()
Call OpenIt("u:", "eins.xls")
Call OpenIt("u:", "zwei.xls")
End Sub
Grüße,
Klaus M.vdT.
Anzeige
AW: VBA Makro
30.07.2010 11:23:44
Sascha
Danke Klaus, muss gestehen, dass ich das leider noch nicht so ganz hinterstiegen habe, aber ich werde mich dann mal daran versuchen!
Gruß,
Sascha
AW: VBA Makro
30.07.2010 11:32:42
Klaus
Hallo Sascha,
Call OpenIt("u:", "eins.xls")
öffnet U:\eins.xls
wenn deine Datei C:\Ablage\Sonstiges\hallo.xls heisst, schreibst du stattdessen
Call OpenIt("C:\Ablage\Sonstiges", "hallo.xls")
sheets("Tabelle1").delete
löscht das erste sheet. Wenn du in jeder Datei ein Sheet namens "Eingabeübersicht" löschen willst, schreib stattdessen
sheets("Eingabeübersicht").delete
Da niemand deine Dateien kennt (daher auch die berechtigten Einwände der anderen Kollegen hier) können wir dir keine Lösungen geben, sondern nur ansätze.
Achso: Vor dem ausprobieren von ALLEM BACKUPS ZIEHEN !!!
Grüße,
Klaus M.vdT.
Anzeige
viele Fragen, keine Antwort.
30.07.2010 10:58:36
Tino
Hallo,
befinden sich diese Dateien in einem Ordner, sind dort auch andere Dateien?
Oder gibt es eine Liste der Dateien?
Welche Reiter sind übrig? Woher kommt die Info welche übrig sind?
Welche Zeilen sollen gelöscht werden und wo befinden sich diese?
Dann sollte es eigentlich nicht so schwer sein. ;-)
Gruß Tino
AW: viele Fragen, keine Antwort.
30.07.2010 11:20:04
Sascha
Hallo Tino,
dann versuche ich mal die Fragen zu beantworten:
Ja es befinden sich alle Dateien in einem Ordner und es gibt dort keine anderen Dateien.
Es gibt keine Liste der Dateien.
Die Reiter sind alle gleich benannt, von daher könnte die onfo wohl darüber kommen, welche übrig bleiben sollten und welche nicht.
Die Zeilen und/oder Spalten, die gelöscht werden sollen, befinden sich logischerweise auf den übrig gebliebenen Reitern. Es soll auf dem einen Reiter, nennen wir ihn mal XYZ, alle Spalten ab L und alle Zeilen ab 181 gelöscht werden.
Danke,
Sascha
Anzeige
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
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige