AW: Help please -- Makro kopieren
20.08.2008 12:32:12
sockel939
Mein Code
Private Sub CommanButton_click()
Range("A1:M1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Fett"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Selection.AutoFilter
Dim A As Long
Application.ScreenUpdating = False
For A = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
If Cells(A, "A") = "" Then
Cells(A, "J").Copy Cells(A - 1, "J")
Rows(A).Delete
End If
Next A
Application.ScreenUpdating = True
Dim Zelle As Range
Dim Farbe As Long
For Each Zelle In Range("m2:m1000")
Select Case Zelle.Value
Case "Morgen"
Farbe = 45
Case "Heute"
Farbe = 42
Case "Mittag"
Farbe = 15
Case "Abend"
Farbe = 43
Case Else
Farbe = xlNone
End Select
Range(Zelle.Offset(0, -Zelle.Column + 1), Zelle.Offset(0, -1)).Interior.ColorIndex = Farbe
Next Zelle
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "Grey = Morgen"
Range("A2").Select
ActiveCell.FormulaR1C1 = "Green = Heute"
Range("A3").Select
ActiveCell.FormulaR1C1 = "Orange = Mittag"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Blue = Abend"
Range("A5").Select
Range("A5:M2600").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A4:D4,D3:D4").Select
Range("D4").Activate
ActiveWindow.FreezePanes = True
Range("A4").Select
Rows("4:4").Select
Columns.AutoFit
ActiveWindow.Zoom = 91
Range("A5:M500").Select
Selection.Sort Key1:=Range("A6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A2").Select
ActiveWorkbook.Save
Dim vbc As Object
With Workbooks("exported excelfile.xls").VBProject
For Each vbc In .VBComponents
Select Case vbc.Type
Case 1, 2, 3: .VBComponents.Remove .VBComponents(vbc.Name)
Case 100
With vbc.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
End With
End Sub
Naja jedenfalls werden die vergebenen Farben nicht mitgespeichert :(