2 Codes in einen vereinen
20.01.2006 19:48:04
Korl
ich bins nochmal. Wie kann ich ich 2 Codes zu einem vereinen.
With wksT1
.Columns("B:B").Cut
.Range("A1").Insert Shift:=xlToRight
.Columns("G:G").Copy
.Range("D1").PasteSpecial Paste:=xlValues
.Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Cells.NumberFormat = "General"
.Range("E:I").ClearContents
.Range("E1:E" & lLetzteGl).FormulaR1C1 = "=TRIM(RC[-3])"
.Range("F1:F" & lLetzteGl).FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-1],Ort,2,0)),IF(COUNTIF(R1C[-1]:RC[-1],RC[-1])=1,1,0),IF(VLOOKUP(RC[-1],Ort,2,0)=""x"",2,IF(OR(VLOOKUP(RC[-1],Ort,2,0)=""x"",COUNTIF(R1C[-1]:RC[-1],RC[-1])=1),1,0)))"
.Range("G1:G" & lLetzteGl).FormulaR1C1 = _
"=IF(RC[-1]=1,SUMIF(R1C[-2]:R1000C[-2],RC[-2],R1C[-3]:R1000C[-3]),RC[-3])"
.Range("E1:G" & lLetzteGl).Copy
.Range("E1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Application.CutCopyMode = False
' ab hier müßte Call Del_0_Zeile arbeiten
End With
'Wenn ich hier "Call Del_0_Zeile " anhänge, wird der Code nicht ausgeführt.
Sub Del_0_Zeile()
Dim iRow As Long
Application.ScreenUpdating = False
For iRow = Cells(65536, 6).End(xlUp).Row To 1 Step -1
If Cells(iRow, 6) = 0 Then
Rows(iRow).EntireRow.Delete Shift:=xlUp
ElseIf Cells(iRow, 6) = 1 Then
Cells(iRow, 3).ClearContents
End If
Next iRow
Application.ScreenUpdating = True
End Sub
Wenn ich im Code "Del_0_Zeile" Sheet. select setze funktioniert es auch.
Hätte aber doch mal den Ergeiz, Select zu vermeiden ;-)
Gruß Korl