AW: Zellwerte auslesen und übertragen
26.02.2009 18:42:47
fcs
Hallo Schmidler,
mit folgenden Schleifenkonstruktionen sollte es funktionieren.
Gruß
Franz
Sub Transponieren()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim rngKurzzeichen As Range, rngKurz As Range
Dim lngZei_Q As Long, lngZei_Z As Long
Dim lngSp_Projekt As Long, lngSp_Kurzzeichen
Dim strCodeTeil As String, strKurzzeichen As String
Set wksQuelle = Worksheets("Tabelle1")
Set wksZiel = Worksheets("Tabelle1")
With wksZiel
Set rngKurzzeichen = .Range("H1:L1")
lngSp_Projekt = rngKurzzeichen.Column - 1
lngZei_Z = rngKurzzeichen.Row + 1
'Altdatenlöschen
.Range(.Cells(lngZei_Z, lngSp_Projekt), _
.Cells(.Rows.Count, lngSp_Projekt + rngKurzzeichen.Columns.Count)).ClearContents
End With
lngZei_Q = 2 'Zeile mit dem 1. Projekt in Liste
Do
If wksQuelle.Cells(lngZei_Q, 1).Text = "00" Then
wksZiel.Cells(lngZei_Z, lngSp_Projekt).Value = wksQuelle.Cells(lngZei_Q, 2).Value
wksZiel.Cells(lngZei_Z + 1, lngSp_Projekt).Value = wksQuelle.Cells(lngZei_Q, 3).Value
wksZiel.Cells(lngZei_Z + 2, lngSp_Projekt).Value = wksQuelle.Cells(lngZei_Q, 4).Value
End If
lngZei_Q = lngZei_Q + 1
CodeTeil2:
strCodeTeil = wksQuelle.Cells(lngZei_Q, 2).Value
Do
If wksQuelle.Cells(lngZei_Q, 1).Text = "00" Then
lngZei_Z = lngZei_Z + 3 'nächstes Projekt
Exit Do
End If
If Left(wksQuelle.Cells(lngZei_Q, 2).Text, Len(strCodeTeil)) strCodeTeil Then
'neue Gruppe innerhalb des Projekts
lngZei_Z = lngZei_Z + 2
GoTo CodeTeil2
End If
'Kurzeichen in Spaltentiteln suchen
strKurzzeichen = wksQuelle.Cells(lngZei_Q, 3)
Set rngKurz = rngKurzzeichen.Find(What:=strKurzzeichen, LookIn:=xlValues, _
lookat:=xlWhole)
If rngKurz Is Nothing Then
MsgBox "Kurzeichen """ & strKurzzeichen & """ in Zieltabelle nicht gefunden!"
Else
If Not IsEmpty(wksQuelle.Cells(lngZei_Q, 4)) Then
wksZiel.Cells(lngZei_Z, rngKurz.Column).Value = _
wksQuelle.Cells(lngZei_Q, 4).Value
End If
If Not IsEmpty(wksQuelle.Cells(lngZei_Q, 5)) Then
wksZiel.Cells(lngZei_Z + 1, rngKurz.Column).Value = _
wksQuelle.Cells(lngZei_Q, 5).Value
End If
End If
lngZei_Q = lngZei_Q + 1
If lngZei_Q > wksQuelle.Cells(wksQuelle.Rows.Count, 1).End(xlUp).Row Then Exit Do
Loop
Loop Until lngZei_Q > wksQuelle.Cells(wksQuelle.Rows.Count, 1).End(xlUp).Row
End Sub