AW: Problem noch nicht gelöst - bitte helfen
29.09.2008 17:48:00
fcs
Hallo Christoph,
hier mal dein Code von mir etwas aufbereitet.
Mit den Konstanten am Anfang des Codes kannst du einstellen, ob zu bestimmten Aktionen eine Pause erfolgend soll und wie lang die Pause sein soll.
Gruß
Franz
Private Const bolPause As Boolean = True 'bei False erfolgt Ausführung ohne Pausen
Private Const intPause As Integer = 1 'Ausführungspause in Sekunden
Sub einzelne_kundendateien_ändern()
Dim Fs As FileSearch
Dim Datei As Long, test
Dim Wb As Workbook
Dim Zeile As Long, LetzteZeile As Long
Dim Sheet As Integer
Dim wks2000 As Worksheet
'Const strPfad As String = "C:\Lokale Daten\Test\Daten"
Const strPfad As String = "C:\test\Karteikarten"
Application.ScreenUpdating = True
Set Fs = Application.FileSearch
With Fs
.NewSearch
.LookIn = strPfad
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For Datei = 1 To .FoundFiles.Count
Set Wb = Workbooks.Open(Filename:=.FoundFiles(Datei))
Set wks2000 = Wb.Worksheets("2000")
wks2000.Activate
jahr_link_löschen
Call subPause
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
Worksheets(Sheet).Activate
Call subPause
jahr_link_löschen
Call subPause
Cells(6, 3) = test '?
Call subPause
'letzte Zeile mit Daten in Spalte A im Blatt "2000"
With wks2000
LetzteZeile = Application.WorksheetFunction.Max(8, .Cells(.Rows.Count, _
1).End(xlUp).Row)
End With
'letzte Zeile mit Daten in Spalte A im aktiven Blatt
With ActiveSheet
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile >= 9 Then
'Spalten A (1) bis AB(28) ab Zeile 9 Kopieren
.Range(.Cells(9, 1), .Cells(Zeile, 28)).Copy
Call subPause
wks2000.Activate
Call subPause
'Formate kopieren
wks2000.Cells(LetzteZeile + 1, 1).PasteSpecial Paste:=xlPasteFormats
'Werte kopieren
wks2000.Cells(LetzteZeile + 1, 1).PasteSpecial Paste:=xlPasteValues
Call subPause
End If
End With
Next Sheet
Call sheets_umbenennen(wks:=wks2000)
Call subPause
Call sheet_loeschen(strAusnahme:=wks2000.Name)
Call subPause
Wb.Save
Wb.Close True
Next Datei
End With
End Sub
Sub sheets_umbenennen(wks As Worksheet)
Dim Kundenname As String, TextArray, Teil1 As String, Teil2 As String
Dim strName As String
'Worksheet umbenennen
wks.Activate
strName = wks.Name
'On Error Resume Next
Kundenname = Range("A3")
TextArray = VBA.Split(Kundenname, " ")
If TextArray(1) "" Then
Teil2 = TextArray(1)
Teil1 = TextArray(0)
strName = Teil2 & ", " & Teil1
ElseIf TextArray(0) "" Then
Teil1 = TextArray(0)
strName = Teil1
End If
'Hier noch eine Abfrage für den richtigen Namen einfügen
strName = InputBox("neuer Blattname (ggf. ändern): ", "Blatt umbenennen", strName)
If strName "" Then
wks.Name = strName
End If
End Sub
Sub sheet_loeschen(strAusnahme As String)
'Sheets 2001 bis 2009 löschen
Dim wks As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
For Each wks In ActiveWorkbook.Worksheets
If wks.Name strAusnahme Then
wks.Delete
Call subPause
End If
Next
Application.DisplayAlerts = True
End Sub
Private Sub jahr_link_löschen()
Columns(6).Delete Shift:=xlToLeft
End Sub
Private Sub subPause()
If bolPause = True Then Application.Wait Now + TimeSerial(Hour:=0, Minute:=0, Second:= _
intPause)
End Sub