AW: Poste die vollständigen Codes. oT
24.10.2009 14:59:19
alex
Sub Speichern()
'
' Speichern Makro
'
ActiveWorkbook.Save 'speichert die aktive mappe
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim t As String
Dim s As String
'1 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("F18:F2000")) = 0 Then
Tabelle5.Range("A1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 4) = Application.WorksheetFunction.Max(Columns(6)) Then
Tabelle5.Range("A1") = ActiveCell.Offset(0, 4) & " " & ActiveCell.Offset(0, 5)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
'2 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("j18:j2000")) = 0 Then
Tabelle5.Range("B1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 8) = Application.WorksheetFunction.Max(Columns(10)) Then
Tabelle5.Range("B1") = ActiveCell.Offset(0, 8) & " " & ActiveCell.Offset(0, 9)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
'3 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("n18:n2000")) = 0 Then
Tabelle5.Range("c1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 12) = Application.WorksheetFunction.Max(Columns(14)) Then
Tabelle5.Range("C1") = ActiveCell.Offset(0, 12) & " " & ActiveCell.Offset(0, 13)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
'4 quatal
If Application.WorksheetFunction.CountA(Sheets("KT").Range("r18:r2000")) = 0 Then
Tabelle5.Range("d1") = ""
Else
Tabelle1.Select
[B18].Select
While ActiveCell ""
If ActiveCell.Offset(0, 16) = Application.WorksheetFunction.Max(Columns(18)) Then
Tabelle5.Range("D1") = ActiveCell.Offset(0, 16) & " " & ActiveCell.Offset(0, 17)
End If
ActiveCell.Offset(1, 0).Select
Wend
End If
t = ThisWorkbook.Sheets("kt").Cells(11, 3)
s = ThisWorkbook.Sheets("kt").Cells(3, 5)
Application.ScreenUpdating = False
On Error Resume Next
Workbooks("wartung.xls").Activate
strPath = ThisWorkbook.Path
ChDrive Left(strPath, 2)
ChDir strPath
If Err 0 Then
Workbooks.Open ("../wartung.xls")
With Workbooks("wartung.xls").Sheets("Netz Bln, CS, Sd,").Range("b1:d1000")
Set c = .Find(t, LookAT:=xlPart)
If c.Offset(0, 2) s Then
With Range(c.Offset(0, 2), c.Offset(1, 2))
Set d = .Find(s, LookAT:=xlPart)
d.Offset(0, 3) = ThisWorkbook.Sheets("werte").Cells(1, 1)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 2)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 3)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End With
Else
c.Offset(0, 5) = ThisWorkbook.Sheets("werte").Cells(1, 1)
c.Offset(0, 6) = ThisWorkbook.Sheets("werte").Cells(1, 2)
c.Offset(0, 7) = ThisWorkbook.Sheets("werte").Cells(1, 3)
c.Offset(0, 8) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End If
End With
Err.Clear
Else
With Workbooks("wartung.xls").Sheets("Netz Bln, CS, Sd,").Range("b1:d1000")
Set c = .Find(t, LookAT:=xlPart)
If c.Offset(0, 2) s Then
With Range(c.Offset(0, 2), c.Offset(1, 2))
Set d = .Find(s, LookAT:=xlPart)
d.Offset(0, 3) = ThisWorkbook.Sheets("werte").Cells(1, 1)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 2)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 3)
d.Offset(0, 4) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End With
Else
c.Offset(0, 5) = ThisWorkbook.Sheets("werte").Cells(1, 1)
c.Offset(0, 6) = ThisWorkbook.Sheets("werte").Cells(1, 2)
c.Offset(0, 7) = ThisWorkbook.Sheets("werte").Cells(1, 3)
c.Offset(0, 8) = ThisWorkbook.Sheets("werte").Cells(1, 4)
End If
End With
End If
ThisWorkbook.Activate
Application.ScreenUpdating = True
Exit Sub
End Sub