AW: Tabellen neu formatieren
20.01.2005 01:14:54
Luigi
Hi DieterB! Ich habe es versucht, aber es kommt nichts Gutes raus! Was mache ich denn falsch? Gruss!
Luigi
Public
Sub Tabellen_neu_formatieren()
Dim c As Range
Dim be As Range
Dim i As Integer
Dim z As Integer
Dim suchIndex As Integer
Dim entwicklungsjahre
Dim wks As Worksheet
Dim Tabellenbezeichnung As String
z = 11
entwicklungsjahre=Array(1999,2002,2003,2005)
Set wks = Worksheets("Original")
ThisWorkbook.IsAddin = False
wks.Select
wks.Cells(10, 1).Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Selection.EntireRow.Insert
Application.ScreenUpdating = False
For i = 0 To UBound(Entwicklungsjahre) Step 1
suchIndex = 15
Cells(z, 1).Value = Entwicklungsjahre(i)
Do
Set c = Cells.Find(What:=Entwicklungsjahre(i), After:=Cells(suchIndex, 1), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
Range be!!! Damit suche ich die Tabellenbeschreibung in 'der Spalte A (z. B: Produkt A)
Set be = Cells(c.Row, c.Column - 2)
Do
If be Is Nothing Then Exit Do
Set be = Cells(be.Row - 1, be.Column)
Loop While (IsEmpty(be.Value))
Cells(z + 1, 2).Value = be.Value
Range(Cells(c.Row, c.Column - 1), Cells(c.Row, c.Column + 2)).Select: Selection.Cut
On Error Resume Next
'ActiveSheet.Paste Destination:=Worksheets("Original").Range(Cells(z + 2, 2), Cells(z + 2, 5))
ActiveSheet.Paste Destination:=Worksheets("Original").Cells(z + 2, 2)
Cells(z + 4, 1).Select
Selection.EntireRow.Insert
Selection.EntireRow.Insert
suchIndex = c.Row + 4
z = z + 6
End If
Loop Until c Is Nothing
Next i
ThisWorkbook.IsAddin = False
Worksheets("Original").Select
Application.CutCopyMode = False
Set c = Nothing
Set be = Nothing
Application.ScreenUpdating = True
End Sub