Sammelbearbeitung von Dateien
29.09.2008 11:30:41
Dateien
ich benötige eure Hilfe.
Ich erstelle gerade ein Modul, mit dessen hilfe alle gleichartig aufgebauten Excel-Dateien eines Verzeichnisses bearbeitet werden sollen. Leider komme ich im Programmablauf nicht weiter.
Dateiaufbau:
10 Sheets mit den Jahren 2000 bis 2009
Programmspezifikationen:
Alle Dateien sollen nacheinander geöffnet werden
Von 2001 bis 2009 soll jedes sheet geöffnet werden
In jedem Sheet die Spalte f löschen
Inhalt ab Zeile 9 kopieren und in Blatt 2000 nach der zuletzt benutzten zeile einfügen
Das hier mit jedem Sheet bis 2009 machen
Sheets 2001 bis 2009 löschen
Sheet 2000 in Nachname, Vorname umändern
Datei abspeichern, schließen und nächste öffnen.
Irgendwie funktioniert das auch, aber leider blendet er mir in den geänderten Dateien das Workbook aus. Zudem möchte ich trotz der langsamen verarbeitung die Aktionen Blattaktivieren, Zellenaktivierung, Kopieren, Bearbeiten, Markieren, löschen,... am Bildschirm anzeigen lassen
Das umbenennen funktioniert leider auch noch nicht so wie sie soll.
Anbei mein Programmcode und zwei Beispieldateien.
Bitte alles in c:\test und c:\test\karteikarte kopieren.
Ich hoffe, Ihr könnt mir weiterhelfen.
Grüße
christoph
Sub einzelne_kundendateien_ändern()
Dim Fs As FileSearch
Dim Datei As Long
Dim Wb As Workbook
Dim Zeile As Long
Dim Sheet As Integer
Application.ScreenUpdating = True
Set Fs = Application.FileSearch
With Fs
.NewSearch
.LookIn = "C:\test\Karteikarten"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For Datei = 1 To .FoundFiles.Count
Set Wb = GetObject(.FoundFiles(Datei))
Wb.Activate
'Wb.Visible = True
For Sheet = 2 To Worksheets.Count
'Hier muss jetzt Dein Makro hin, das in jeder Datei ablaufen soll
'hier kommt das link löschen hin
Worksheet.Activate
jahr_link_löschen
Cells(10, 3) = test
'letztezeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Zeile = Sheets("2000").Range("A65536").End(xlUp).Offset(1, 0).Row
'Worksheets(i).Range("A26:AB300").Copy
'Sheets("2000").Cells(Zeile, 1).PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
'Application.CutCopyMode = False
Next Sheet
sheets_umbenennen
'sheet_loeschen
Wb.Close True
Next Datei
End With
End Sub
Sub sheets_umbenennen()
'Worksheet umbenennen
Worksheets(1).Activate
'On Error Resume Next
N = ActiveWorkbook.ActiveSheet.Name
kundenname = Range("A3")
TextArray = VBA.Split(kundenname, " ")
'If TextArray(2) "" Then
' teil3 = TextArray(2)
' teil2 = TextArray(1)
' teil3 = TextArray(0)
'Hier noch eine Abfrage für den richtigen Namen einfügen
' Sheets(N).Name = teil3 & " " & teil2 & ", " & teil1
' Exit Sub
'End If
If TextArray(1) "" Then
teil2 = TextArray(1)
teil1 = TextArray(0)
Sheets(N).Name = teil2 & ", " & teil1
Exit Sub
End If
If TextArray(1) "" Then
teil1 = TextArray(0)
Sheets(N).Name = teil1
End If
End Sub
Sub sheet_loeschen()
'Sheets 2001 bis 2009 löschen
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("2001").Delete
ActiveWorkbook.Sheets("2002").Delete
ActiveWorkbook.Sheets("2003").Delete
ActiveWorkbook.Sheets("2004").Delete
ActiveWorkbook.Sheets("2005").Delete
ActiveWorkbook.Sheets("2006").Delete
ActiveWorkbook.Sheets("2007").Delete
ActiveWorkbook.Sheets("2008").Delete
ActiveWorkbook.Sheets("2009").Delete
Application.DisplayAlerts = True
End Sub
Sub jahr_link_löschen()
Columns(6).Delete Shift:=xlToLeft
End Sub