AW: Formel als Wert einfügen
16.12.2016 11:48:15
cH_rI_sI
Anbei noch den ganzen Code:
Sub Plan()
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim iZeile As Long, tempZeile As Long, iZähler As Long
Dim strMark As String
Set WS1 = Worksheets("Questions (SH4)")
Set WS2 = Worksheets("Sample- Corr.-Action-Plan (SH7)")
Set WS3 = Worksheets("Cover Sheet (SH1)")
Application.ScreenUpdating = False
For iZeile = WS1.Cells(WS1.Rows.Count, 9).End(xlUp).Row To 9 Step -1
If IsNumeric(WS1.Cells(iZeile, 9)) And WS1.Cells(iZeile, 9) "" And _
WorksheetFunction.CountIf(WS2.Columns(5), WS1.Cells(iZeile, 1)) = 0 And _
Left(WS1.Cells(iZeile, 1), 4) "Poin" And _
Left(WS1.Cells(iZeile, 1), 4) "Degr" And _
Left(WS1.Cells(iZeile, 1), 4) "Conv" And _
WS1.Cells(iZeile, 1) 1 And _
WS1.Cells(iZeile, 9) 10 Then
iZähler = iZähler + 1
tempZeile = WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row + 1
WS2.Cells(tempZeile, 5) = WS1.Cells(iZeile, 1)
WS2.Cells(tempZeile, 6) = WS1.Cells(iZeile, 11)
Select Case WS1.Cells(iZeile, 9)
Case 8: strMark = "V"
Case 6: strMark = "F"
Case 4: strMark = "A"
Case 0: strMark = "A"
End Select
WS2.Cells(tempZeile, 7) = strMark
WS2.Cells(tempZeile, 2) = WS3.Range("F7").Value
WS2.Cells(tempZeile, 3) = WS3.Range("F12").Value
WS2.Cells(tempZeile, 8) = WS3.Range("F11").Value
WS2.Cells(tempZeile, 1).Formula = "=""" & WS3.Range("F6").Value & "-""&ROW()-8"
WS2.Cells(tempZeile, 1).Value = WS2.Cells(tempZeile, 1).Value
WS2.Cells(tempZeile, 4) = "S"
End If
Next iZeile
tempZeile = WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row
If WS2.Cells(WS2.Rows.Count, 1).End(xlUp).Row > 8 Then
With WS2.Range(WS2.Cells(9, 1), WS2.Cells(tempZeile, 11))
.Interior.Pattern = xlNone
.Font.Bold = False
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.WrapText = True
.Rows.EntireRow.AutoFit
End With
ActiveWorkbook.Worksheets("Sample- Corr.-Action-Plan (SH7)").Sort.SortFields.Add _
Key:=Range("E9:E509"), SortOn:=xlSortOnValues, Order:=xlAscending, _
CustomOrder:= _
"1.1,1.2,1.3,1.4,1.5,2.1,2.2,2.3,2.4,2.5,3.1,3.2,3.3,3.4,3.5,3.6,4.1,4.2,4.3,4.4,4.5,5. _
1,5.2,5.3,5.4,5.5,5.6,5.7,5.8,5.9,5.10,5.11,6.1,6.2,6.3,6.4,6.5,6.6,7.1,7.2,7.3,7.4,7.5,7.6,7.7,8.1,8.2,8.3,9.1,9.2,10.1,10.2,10.3,11.1,11.2" _
, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sample- Corr.-Action-Plan (SH7)").Sort
.SetRange Range("A8:K509")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If Val(Application.Version) >= 12 Then
' ab Excel 2007: Sortierung loeschen um Fehlermeldung zu vermeiden!
Worksheets(ActiveSheet.Name).Sort.SortFields.Clear
End If
End If
End Sub