AW: VBA
21.01.2013 13:15:50
Klaus
Hi,
das sollte es tuen. Starte das Makro "KorrigiereCharge" von Hand. Starte NICHT das Makro "RekursivKorrigieren", dass muss vom anderen Makro aufgerufen werden.
Option Explicit
Sub KorrigiereCharge()
Dim wksSource As Worksheet
Dim wksTarget As Worksheet
Dim lRowLast As Long
Dim lRowTarget As Long
Set wksSource = Sheets("Tabelle1")
Set wksTarget = Sheets("Tabelle2")
wksTarget.Cells.ClearContents
RekursivKorrigieren
lRowLast = wksSource.Cells(Rows.Count, 1).End(xlUp).Row
lRowTarget = wksTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
With wksSource
.Range("A1").EntireRow.Copy wksTarget.Range("A1")
.Range(.Cells(2, 1), .Cells(lRowLast, 1)).EntireRow.Copy
wksTarget.Cells(lRowTarget, 1).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = xlCopy
End Sub
Sub RekursivKorrigieren()
Dim wksSource As Worksheet
Dim wksTarget As Worksheet
Dim lRowLast As Long
Dim lRowTarget As Long
Dim iColCharge As Integer
Dim iColLast As Integer
Dim rCharge As Range
Dim bAgain As Boolean
Set wksSource = Sheets("Tabelle1")
Set wksTarget = Sheets("Tabelle2")
iColCharge = 14
bAgain = False
lRowTarget = wksTarget.Cells(Rows.Count, iColCharge).End(xlUp).Row
With wksSource
lRowLast = .Cells(Rows.Count, iColCharge).End(xlUp).Row
iColLast = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
For Each rCharge In .Range(.Cells(2, iColCharge), .Cells(lRowLast, iColCharge))
.Cells(rCharge.Row, iColLast).FormulaR1C1 = "=LEFT(RC[-8],FIND(""/"",RC[-8])-1)"
If IsError(.Cells(rCharge.Row, iColLast).Value) Then
Else
rCharge.EntireRow.Copy
lRowTarget = lRowTarget + 1
wksTarget.Cells(lRowTarget, 1).PasteSpecial xlPasteValues
wksTarget.Cells(lRowTarget, iColCharge).Value = wksTarget.Cells(lRowTarget, _
iColLast).Value
bAgain = True
End If
Next rCharge
For Each rCharge In .Range(.Cells(2, iColCharge), .Cells(lRowLast, iColCharge))
If IsError(.Cells(rCharge.Row, iColLast).Value) Then
Else
.Cells(rCharge.Row, iColCharge).Value = Application.WorksheetFunction.Substitute(. _
Cells(rCharge.Row, iColCharge).Value, .Cells(rCharge.Row, iColLast) & "/", "")
End If
Next rCharge
End With
'Rekursiv aufrufen
If bAgain Then RekursivKorrigieren
End Sub
Grüße,
Klaus M.vdT.