Eingaben in Tabelle passend einsortieren - II
06.01.2012 02:52:53
NoNet
Hallo Tobias,
ich habe das Makro bereits sehr variabel auf Deinen ursprünglichen Tabellenaufbau hin erstellt.
Wenn Du den Aufbau der Tabelle nun nachträglich änderst, sind natürlich Anpassungen nötig.
Die erste Änderung (Eingabebereich) hast Du ja bereits durchgeführt - genau deshalb habe ich das Makro auch recht variabel gehalten. Die zweite notwendige Änderung hättest Du auch entdecken können (da im Code kommentiert !) :
Deine Ausgabetabelle beginnt nun in Zeile 9 und nicht mehr in Zeile 8, daher folgende Codezeile :
lngT = 9 'Startzeile der Ausgabetabelle
Hier der gesamte Code (letzte Änderung siehe *** SCHNIPP ****SCHNAPP **** :
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit Sub 'Falls Makro nicht ausgeführt werden soll
Dim lngZ As Long, rngEingaben As Range, lngT As Long
Set rngEingaben = [B3:B7] 'Definition Eingabenbereich
lngT = 9 'Startzeile der Ausgabetabelle
'Falls Eingaben in B3:B7 vollständig
If Not Intersect(Target, rngEingaben) Is Nothing And _
Application.CountA(rngEingaben) = rngEingaben.Count Then
lngZ = Cells(Rows.Count, 1).End(xlUp).Row 'letzte belegte Zeile der Tabelle ermitteln
If Application.CountIf(Range("A" & lngT + 1 & ":A" & lngZ), rngEingaben.Cells(1, 1)) = _
0 Then
lngZ = Cells(Rows.Count, 1).End(xlUp).Row + 1 'nächste freie Zeile unterhalb _
Tabelle
Else
If Cells(lngZ, 1) = rngEingaben.Cells(1, 1) Then
lngZ = lngZ + 1
Else
lngZ = lngT + Application.Match(rngEingaben.Cells(1, 1) + 1, _
Range("A" & lngT + 1 & ":A" & lngZ), 0)
End If
End If
Rows(lngT + 1).Copy
Rows(lngZ).Insert Shift:=xlDown
'********* Ab hier wurde geändert : ******* SCHNIPP *******
Cells(lngZ, 1) = rngEingaben.Cells(1, 1) 'Code übertragen
rngEingaben.Offset(1).Resize(rngEingaben.Count - 1).Copy 'Eingaben o. CODE kopieren
'Eingaben ohne CODE transponiert ab Spalte 3 einfügen :
Cells(lngZ, 3).PasteSpecial Paste:=xlValues, Transpose:=True
'********* Bis hier wurde geändert : ****** SCHNAPP *******
rngEingaben.ClearContents 'Eingaben löschen
rngEingaben.Cells(1, 1).Select 'Erste Eingabezelle aktivieren
Application.CutCopyMode = False
End If
End Sub
Gruß, NoNet