|
Hi, da hast du Recht!
Ich musste es erst umschreiben, da dies hier nur ein kleines beispiels ist
Option Explicit
Sub gruppe_rz_kopieren()
Application.DisplayAlerts = False
Dim i, j, k, l, m, n, Ende As Long
Dim s, Gruppe, rz, blattname As String
i = 2
j = 2
l = 1
m = 2
While Tabelle1.Cells(j, 1) <> ""
Gruppe = Tabelle3.Cells(j, 1)
m = 2
While Tabelle1.Cells(m, 2) <> ""
rz = Tabelle3.Cells(m, 2)
blattname = Gruppe & "_" & rz 'hier der Tabellenblattname aus Beschr und rz
With Worksheets.Add
.Name = blattname
.Move after:=Sheets(Worksheets.Count)
End With
'ThisWorkbook.Worksheets.Add.Name = blattname
For l = 1 To 5
Worksheets(blattname).Cells(1, l) = Tabelle1.Cells(1, l)
Next l
i = 2
k = 2
While Tabelle1.Cells(i, 1) <> ""
If Tabelle1.Cells(i, 1) = Gruppe And Tabelle1.Cells(i, 2) = rz Then
For l = 1 To 6
Worksheets(blattname).Cells(k, l) = Tabelle1.Cells(i, l)
Next l
For l = 3 To 6
Worksheets(blattname).Cells(k, l).NumberFormat = "#,##0"
Next l
k = k + 1
End If
i = i + 1
Wend
m = m + 1
If Worksheets(blattname).Cells(2, 1) = "" Then
'Application.DisplayAlerts = False
Worksheets(blattname).Delete
'Application.DisplayAlerts = True
End If
Wend
j = j + 1
Wend
Dim icounter As Integer
Dim zähler
Dim a, b, c As String
Dim d As Integer 'd = 10 Zeit t
a = "A1"
b = "A2"
c = "A3"
d = 10
'neues Blatt einfügen, umbenennen in Ergebnis
Sheets(2).Select
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Ergebnis"
Range(a) = "Beschr"
Range(b) = "Rzins"
Range(c) = "t"
For icounter = 0 To d
Range(c).Select
ActiveCell.Offset(1 + icounter, 0).Value = icounter
Next icounter
ActiveSheet.Cells(1048576, 1).End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1") = "t"
Range(c).Select
Selection.End(xlDown).Select
For icounter = 0 To d
ActiveCell.Offset(1 + icounter, 0).Value = icounter
Next icounter
Range("B1").Select
ActiveCell.Value = Sheets(4).Cells(2, 1)
Range("B2").Select
ActiveCell.Value = Sheets(4).Cells(2, 2)
' Aus auf das Blatt 3 übertragen
Sheets(4).Select
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Ergebnis").Select
Range("B4").Select
ActiveSheet.Paste
Range("B3").Value = "Aus"
' Ein_Korr auf das Blatt Ergebnis übertragen
Sheets(4).Select
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Ergebnis").Select
Range("B16").Select
ActiveSheet.Paste
Range("B15").Value = "Ein_Korr"
'
For zähler = 5 To Worksheets.Count
Sheets(zähler).Select
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Ergebnis").Select
Range("A4").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
Range("A3").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Range("A1").Value = "Aus"
Sheets(zähler).Select
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Ergebnis").Select
Range("A16").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveSheet.Paste
Range("A15").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Range("A1").Value = "Ein_Korr"
Range("A1").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Range("A1").Value = Sheets(zähler).Cells(2, 1)
Range("A2").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Range("A1").Value = Sheets(zähler).Cells(2, 2)
Next zähler
Dim wks As Worksheet
For Each wks In Worksheets
If wks.Name <> "Tabelle1" And wks.Name <> "Tabelle2" And wks.Name <> "Ergebnis" Then
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
End If
Next wks
Application.DisplayAlerts = True
End Sub
|