AW: brauche Hilfe von einem Profi
08.12.2005 01:01:11
einem
hallo Markus,
möglich in dem Sinn ist es schon...wenn du so fragst...
Sub Tab_erst()
Dim i%, s%
s = 4
Application.ScreenUpdating = False
On Error GoTo ende
For i = 12 To 29
If Cells(i, 1) = "F1" Then
Range(Cells(34, s), Cells(35, s + 2)).Value = _
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Value
s = s + 3
End If
Next
s = 4
For i = 12 To 29
If Cells(i, 1) = "F2" Then
Range(Cells(36, s), Cells(37, s + 2)).Value = _
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Value
s = s + 3
End If
Next
s = 4
For i = 12 To 29
If Cells(i, 1) = "F3" Then
Range(Cells(38, s), Cells(39, s + 2)).Value = _
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Value
s = s + 3
End If
Next
s = 4
For i = 12 To 29
If Cells(i, 1) = "F4" Then
Range(Cells(40, s), Cells(41, s + 2)).Value = _
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Value
s = s + 3
End If
Next
Range("D34:I34").UnMerge
Range("D34").AutoFill Destination:=Range("D34:F34"), Type:=xlFillCopy
Range("G34").AutoFill Destination:=Range("G34:I34"), Type:=xlFillCopy
Range("D34:I35").Sort Key1:=Range("D34"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, Orientation:=xlLeftToRight
Application.DisplayAlerts = False
Range("D34:F34").Merge
Range("G34:I34").Merge
Range("D36:I36").UnMerge
Range("D36").AutoFill Destination:=Range("D36:F36"), Type:=xlFillCopy
Range("G36").AutoFill Destination:=Range("G36:I36"), Type:=xlFillCopy
Range("D36:I37").Sort Key1:=Range("D36"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, Orientation:=xlLeftToRight
Range("D36:F36").Merge
Range("G36:I36").Merge
Range("D38:I38").UnMerge
Range("D38").AutoFill Destination:=Range("D38:F38"), Type:=xlFillCopy
Range("G38").AutoFill Destination:=Range("G38:I38"), Type:=xlFillCopy
Range("D38:I39").Sort Key1:=Range("D38"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, Orientation:=xlLeftToRight
Range("D38:F38").Merge
Range("G38:I38").Merge
Range("D40:I40").UnMerge
Range("D40").AutoFill Destination:=Range("D40:F40"), Type:=xlFillCopy
Range("G40").AutoFill Destination:=Range("G40:I40"), Type:=xlFillCopy
Range("D40:I41").Sort Key1:=Range("D40"), Order1:=xlAscending, Header:=xlGuess _
, OrderCustom:=1, Orientation:=xlLeftToRight
Range("D40:F40").Merge
Range("G40:I40").Merge
ende:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
ist allerdings nur ein Ansatz für eine mögliche Lösung...
gruß Herbert
https://www.herber.de/bbs/user/29038.xls