AW: Ergebnis d. Makros unterschiedlich bei Zellaus
05.02.2007 22:59:05
Marc
Hallo Sepp,
vielen Dank schonmal für die schnelle Antwort. Ich hoffe, der Code sagt Dir etwas. Ich habe sehr viele Sendkeys verwendet. Aber ich habe VBA ja auch nur auf mäßig stehen. Wenn Du mir dazu ebenfalls Verbesserungen sagen kannst, würde ich mich ebenfalls sehr freuen!
Dazu muß ich noch sagen, dass sich der Bereich, von dem ich spreche zwischen den Zellen B40 und K45 befindet. Innerhalb dieses Bereiches befinden sich auch einige verbundene Zellen. Die Formatierung muß leider so sein. Durch das Makro wird der Bereich Zeilenweise erweitert, bis er B40 bis K51 ausfüllt. Die erste und die letzte Zeile des Bereichs habe ich in der Spalte A mit je einer 1 markiert, wodurch ich den Bereich Zeilenmäßig begrenze. Ich hoffe, das hilft bei der Analyse.
Grüße,
Marc Richter
Sub Makro1()
Call Makro6
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
ActiveCell.Select
Selection.Rows.EntireRow.Select
Selection.Insert Shift:=xlDown
SendKeys "{LEFT}", True
SendKeys "{RIGHT}", True
SendKeys "+{RIGHT}", True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Locked = False
End With
SendKeys "{RIGHT}", True
SendKeys "{RIGHT}", True
SendKeys "{RIGHT}", True
SendKeys "{RIGHT}", True
SendKeys "{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
.Locked = False
End With
SendKeys "{DOWN}", True
SendKeys "{HOME}", True
SendKeys "{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
Selection.Copy
SendKeys "{HOME}", True
SendKeys "{UP}", True
SendKeys "{RIGHT}", True
ActiveSheet.Paste
Application.CutCopyMode = False
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 = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
SendKeys "{HOME}", True
SendKeys "{DOWN}", True
SendKeys "{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
SendKeys "+{RIGHT}", True
Selection.ClearContents
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
SendKeys "{UP}", True
Selection.Rows.EntireRow.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
SendKeys "{RIGHT}", True
End Sub