AW: Berechnung auf manuell statt automatisch
21.08.2007 11:10:28
marcl
das möchtest Du Dir antun? na gut. Hier mein verbrochener Code:
Sub Personen()
Workbooks.Open Filename:= _
"\\...\Personen_Makro.xls"
Application.Run ("Personen_Makro.xls!start2")
End Sub
Sub start2()
quelldatei = ActiveWorkbook.Name
Workbooks.Open Filename:=Range("Q5")
Windows(quelldatei).Activate
Call start
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub
Sub start()
frage = MsgBox("Versand vor PK?", vbYesNo)
Range("i1") = frage
Range("A18") = ActiveSheet.Name
quellblatt = Range("A18")
makrodatei = ActiveWorkbook.Name
ActiveWindow.WindowState = xlMinimized
quelldatei = ActiveWorkbook.Name
Windows(makrodatei).WindowState = xlNormal
Sheets(quellblatt).Copy before:=Workbooks(quelldatei).Sheets(1)
Windows(makrodatei).Visible = False
Call aufbereitung
Application.DisplayAlerts = False
ActiveSheet.Delete
ActiveWorkbook.Close
Windows(makrodatei).Visible = True
ActiveWorkbook.Save
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
Sub aufbereitung()
Range("B5") = ""
quelldatei = ActiveWorkbook.Name
quellblatt = Range("A18")
Sheets("index").Select
Range("A30").FormulaR1C1 = "=" & quelldatei & "!R[-26]C[2]"
Range("A50").FormulaR1C1 = "=" & quelldatei & "!R[-47]C[2]"
Sheets(quellblatt).Select
Range("D5").Select
Do While ActiveCell ""
Calculate
Call ziel
zieldatei = ActiveWorkbook.Name
Windows(quelldatei).Activate
Range("A7") = zieldatei
Do While Range("B5") 7 Then
Range("A31:H36").ClearContents
Range("H42").FormulaR1C1 = "Tabelle 7"
End If
Windows(quelldatei).Activate
Windows("Personen.xls").Visible = False
Workbooks.Open Filename:="\\...\Abgänge.xls"
Application.Run ("Abgängeo.xls!start")
Sheets("Statistik-Infoseite").Move After:=Sheets(Sheets.Count)
Call speichern
Application.DisplayAlerts = False
Range("B5") = ""
anzahl = 0
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub speichern()
zieldatei = ActiveWorkbook.Name
Application.DisplayAlerts = False
aaname = Sheets("Insgesamt").Range("C14")
Sheets("Tabelle1").Delete
Dim sh
Application.DisplayAlerts = True
Windows("Personen.xls").Visible = True
monat = Format(Workbooks("Personen.xls").Sheets("Index").Range("A3"), "MMM-YY")
pfadname = Workbooks("Personen.xls").Sheets("Makrodaten").Range("Q7") & "Arbeitslose\vor_PK\ _
Arbeitslose nach ausgewählten Merkmalen für " & aaname & " Stand " & monat & ".xls"
If Sheets("Makrodaten").Range("I1") = 7 Then pfadname = Workbooks("Personen.xls").Sheets(" _
Makrodaten").Range("Q7") & "A\nach_PK\A " & aaname & " Stand " & monat & ".xls"
Windows(zieldatei).Activate
Sheets("Deckblatt").Select
Range("A1").Select
ActiveWorkbook.SaveAs Filename:=pfadname
ActiveWorkbook.Close
Application.DisplayAlerts = False
Windows("Abgänge.xls").Visible = True
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Sub ziel()
Workbooks.Add
Application.DisplayAlerts = False
Dim sh, Cs_name
For Each sh In Worksheets
sh.Activate
If sh.Name "Tabelle1" Then
sh.Delete
End If
Next sh
Application.DisplayAlerts = True
End Sub
Sub kopieren()
zieldatei = Range("A7")
quelldatei = ActiveWorkbook.Name
quellblatt = Range("A18")
blattname = "Statistik"
Windows(zieldatei).Activate
Workbooks(quelldatei).Sheets(blattname).Copy After:=Sheets(Sheets.Count)
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks(quelldatei).Activate
nam = Sheets(quellblatt).Range("c4")
Workbooks(zieldatei).Activate
ActiveSheet.Name = nam
Cells.Select
Selection.Replace What:="#NV", Replacement:=" -", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
End Sub
Sub kopieren2()
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Rows("60:60").ClearContents
Columns("AA:AA").ClearContents
Range("A1").Select
End Sub
Gruß
marcl