AW: Excel änder Zellformat beim Öffnen mit VBA
24.09.2007 16:39:00
Andreas
Ist aber wirklich so , dass ich komma werte habe wenn ich die datei Moser38 durch doppelclick öffne
Wenn ich das makro mit f8 durchtippe sehe ich eben dass die datei moser38 direkt mit den tausendertrennzeichen geöffnet wird.
Hier die Datei: https://www.herber.de/bbs/user/46295.xls
und hier der Code:
Sub KW_auswerten()
' KW_auswerten Makro
' Makro am 17.09.2007 von Andreas Werner erstellt
' Tastenkombination: Strg+a
With Range("B5:BA5").Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
If MsgBox("Ist die Zelle mit der KW die aktualisiert werden soll ausgewählt?", vbYesNo) = _
vbNo Then GoTo ende
Range("B5:BA5").Interior.ColorIndex = xlNone
'Einlesen der Suchdaten
kw_such = ActiveCell.Value
name_such = Cells(3, 18).Value
jahr_such = Cells(3, 4).Value
team_such = Cells(3, 12).Value
'Relevante Dateien öffnen
Dim Pfad, File As String
Pfad_gef = "L:\Auswertungen\Gefährdete Endtermine FT" & team_such & "\" & jahr_such & "\"
File_gef = "gef" & team_such & "" & kw_such & ".xls"
Pfad = "L:\Auswertungen\Produktivität FT" & team_such & "\" & jahr_such & "\ _
Einzelproduktivität\" & name_such & "\"
File = "" & name_such & "" & kw_such & ".xls"
Workbooks.Open Filename:=Pfad_gef + File_gef
Workbooks.Open Filename:=Pfad + File
'Persönlliche Rückmeldezeit der KW nach erster Spalte sortieren und Variablen übergeben
With Workbooks(File).Sheets(name_such & kw_such)
.Activate
.Range("F:F,L:L,M:M,N:N,O:O").NumberFormat = "0.000"
.Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Cells.Find(What:="Rückmeldetezeit (M) gesamt:", After:=ActiveCell, LookIn _
:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
rückmeld_m_ges = ActiveCell.Offset(0, 5)
Cells.Find(What:="Rückmeldetezeit (P) gesamt:", After:=ActiveCell, LookIn _
:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
rückmeld_p_ges = ActiveCell.Offset(0, 5)
Cells.Find(What:="Anwesenheitszeit gesamt:", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
anwesenheit_ges = ActiveCell.Offset(0, 5)
End With
'Letzte Zeile der Fertigungsauftträge festlegen
Range("O1:O500").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:= _
xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
letzte_zeile = ActiveCell.Row
'Spalten tauschen
Columns("H:H").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste
Columns("Q:Q").Select
Selection.Cut
Columns("D:D").Select
ActiveSheet.Paste
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("B1").Value = ("Auftrags-Nr")
Range("C1").Value = ("Bez")
Range("D1").Value = ("Vorgangsbeschreibung")
Range("E1").Value = ("Rest Au")
'Berechnung Rest Au
For i = 2 To letzte_zeile
Cells(i, 5).FormulaR1C1 = "=IF(RC[7]0,RC[7],RC[8]+RC[9])"
Next i
Range(Cells(2, 5), Cells(letzte_zeile, 5)).NumberFormat = "0.00"
'Vorhandenes Blatt "Gefiltert" löschen
'For i = 1 To Sheets.Count
'If Sheets(i).Name = "Gefiltert" Then Sheets(i).Delete: Exit For
'Next
'Zusatzblatt einfügen
Sheets.Add
With Sheets("Tabelle1")
.Select
.Move After:=Sheets(2)
.Name = "Gefiltert"
End With
'Filtern der Rückgemeldeten Zeiten nach "Auftragsnummer in der gefährdeten Liste vorhanden"
'Korrektur für Einsatz Spezialfilter
Workbooks(File_gef).Sheets("gef" & team_such & kw_such & "Mo").Activate
Range("A1").FormulaR1C1 = "Auftrags-Nr"
Range("A2").Select
ActiveCell.FormulaR1C1 = "1"
Range("A1", Range("A65536").End(xlUp)).Copy
Workbooks(File).Sheets("Gefiltert").Activate
ActiveCell.PasteSpecial
Selection.End(xlDown).Select
'Spezialfilter
i = ActiveCell.Address
Sheets(name_such & kw_such).Columns("B:E").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("A1:" & i), CopyToRange:=Range("C1"), Unique:=False
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
'Blatt bereinigen
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
'Summe bilden und Summe der rückgemeldeten Zeiten in Variable
Range("D1").End(xlDown).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
letzte_zeile2 = ActiveCell.Row
Set Bereich = Range("b2", Cells(letzte_zeile2, 4))
End With
With ActiveCell.Offset(1, 0)
.Activate
.Value = Application.WorksheetFunction.Sum(Bereich)
'.FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
'ActiveCell.FormulaR1C1 = "=SUM(R[-1]C)"
End With
rückmeld_gef_ges = ActiveCell.Value
'Ergebnis in Tabelle unter den entsprechenden KW eintragen
Workbooks("Auswertung_prod_term.xls").Sheets(name_such).Activate
ActiveCell.Offset(1, 0) = rückmeld_p_ges / anwesenheit_ges
ActiveCell.Offset(2, 0) = rückmeld_gef_ges / rückmeld_p_ges
ActiveCell.Offset(3, 0) = rückmeld_p_ges
ActiveCell.Offset(4, 0) = rückmeld_gef_ges
Range("A1").Select
Workbooks(File).Close False
Workbooks(File_gef).Close False
MsgBox ("Erfolgreich abgeschlossen!")
ende:
End Sub