AW: viel Glück...oT
12.11.2012 12:42:06
Tino
Hallo,
ok. noch ein Versuch.
Sub kopiereDaten()
Dim oWS As Worksheet, tmpArray, iCalc%, lngOffset&
iCalc = Application.Calculation
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With Sheets("Werte aktuell")
'alte Daten löschen für neue, evtl. löschen wenn nicht gewollt
.UsedRange.ClearContents
For Each oWS In ThisWorkbook.Worksheets
'alle Tabellen die Tabelle im Namen haben,
'evtl. anderer Filter verwenden
If InStr(oWS.Name, "Tabelle") > 0 Then
With oWS
tmpArray = .Range("A1", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value2
End With
With .Cells(.Rows.Count, 2).End(xlUp).Offset(lngOffset, 0).Resize(Ubound(tmpArray), Ubound(tmpArray, 2))
.Value = tmpArray
With .Columns(1)
.Offset(, -1).FormulaR1C1 = "=LEFT(RC[1],4)"
.Offset(, 5).FormulaR1C1 = "=LEFT(RC[-4],4)"
.Offset(, 6).FormulaR1C1 = "=RIGHT(RC[-1],2)"
.Offset(, 7).FormulaR1C1 = _
"=IF(OR(31-RC[-1]=0,32-RC[-1]=0),RIGHT(RC[-6],2),""xx"")"
.Offset(, 9).FormulaR1C1 = "=RC[-10]&RC[-4]"
.Offset(, 11).FormulaR1C1 = _
"=IF(RC[-4]=""xx"",RC[-12]&RC[-6],RC[-12]&RC[-6]&RC[-4])"
End With
End With
lngOffset = 1
End If
Next oWS
End With
Application.EnableEvents = True
Application.Calculation = iCalc
Application.ScreenUpdating = True
End Sub
Gruß Tino