AW: Zeilen zu einem Datensatz zusammenfassen
25.06.2007 14:49:00
Renee
Hello Katja,
Du kannst diesen Code in DieseArbeitsmappe kopieren.
Wenn Du jetzt im Quellenblatt die Zellen einer Lieferung markierst und dann Rechtsklick, wirst Du nach der Zieladdresse gefragt, wo dann die Zusammenfassung gemacht wird:
Option Explicit
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As _
Boolean)
' Code by Renee Sulaweyo
' June 2006
Dim dRowIx As Double
Dim dTargetRow As Double
Dim dTargetCol As Double
Dim vTargetCell As Variant
Dim sNr() As String
Dim sDesc() As String
Dim iCnt() As Integer
Dim ixArr As Integer
Dim sErrMsg As String
Dim bDoIt As Boolean
If Target.Rows.Count = 1 Or _
Target.Columns.Count 6 Or _
Left(Target.Cells(1, 1).Address, 3) "$A$" Then Exit Sub
vTargetCell = InputBox("Bitte geben Sie die Adresse der Zielzelle an:", _
"Sendung zusammenfassen", "A" & Target.Row + Target.Rows.Count)
On Error Resume Next
vTargetCell = UCase(vTargetCell)
bDoIt = True
If Not (Sh.Range(vTargetCell).Address(False, False) = vTargetCell) Then bDoIt = False
If Not bDoIt Then
MsgBox "Aktion abgebrochen", vbOKOnly + vbExclamation, "Sendung zusammenfassen"
Exit Sub
End If
On Error GoTo 0
dTargetRow = Sh.Range(vTargetCell).Row
dTargetCol = Sh.Range(vTargetCell).Column
Application.ScreenUpdating = False
Sh.Cells(dTargetRow, dTargetCol) = Target.Cells(1, 1)
Sh.Cells(dTargetRow, dTargetCol + 1) = Target.Cells(1, 2)
ReDim sNr(0)
ReDim sDesc(0)
ReDim iCnt(0)
sNr(0) = Target.Cells(1, 3)
sDesc(0) = Target.Cells(1, 4)
iCnt(0) = 1
Sh.Cells(dTargetRow, dTargetCol + 5) = Target.Cells(1, 6)
sErrMsg = ""
For dRowIx = 1 To Target.Rows.Count
If Target.Cells(dRowIx, 1) Sh.Cells(dTargetRow, dTargetCol) _
Then sErrMsg = "AUFTRAG"
If Target.Cells(dRowIx, 2) Sh.Cells(dTargetRow, dTargetCol + 1) _
Then sErrMsg = "EMPFÄNGER"
If Target.Cells(dRowIx, 6) Sh.Cells(dTargetRow, dTargetCol + 5) _
Then sErrMsg = "LIEFERDATUM"
If sErrMsg "" Then
MsgBox "Kein EINDEUTIGKEIT im " & sErrMsg & "!" & vbCrLf & _
"Aktion abgebrochen!", vbOKOnly + vbExclamation, "Sendung zusammenfassen"
Sh.Range(Sh.Cells(dTargetRow, dTargetCol), _
Sh.Cells(dTargetRow, dTargetCol + 5)).ClearContents
Exit Sub
End If
bDoIt = True
For ixArr = 0 To UBound(sNr)
If sNr(ixArr) = Target.Cells(dRowIx, 3) Then
If dRowIx > 1 Then iCnt(ixArr) = iCnt(ixArr) + 1
bDoIt = False
End If
Next ixArr
If bDoIt Then
ReDim Preserve iCnt(ixArr)
ReDim Preserve sNr(ixArr)
ReDim Preserve sDesc(ixArr)
iCnt(ixArr) = 1
sNr(ixArr) = Target.Cells(dRowIx, 3)
sDesc(ixArr) = Target.Cells(dRowIx, 4)
End If
Sh.Cells(dTargetRow, dTargetCol + 4) = Sh.Cells(dTargetRow, dTargetCol + 4) & _
IIf(dRowIx = 1, "", ", ") & Target.Cells(dRowIx, 5)
Next dRowIx
For ixArr = 0 To UBound(sNr)
Sh.Cells(dTargetRow, dTargetCol + 2) = Sh.Cells(dTargetRow, dTargetCol + 2) & _
IIf(ixArr = 0, "", ", ") & _
iCnt(ixArr) & "x" & sNr(ixArr)
Sh.Cells(dTargetRow, dTargetCol + 3) = Sh.Cells(dTargetRow, dTargetCol + 3) & _
IIf(ixArr = 0, "", ",") & _
iCnt(ixArr) & "x" & sDesc(ixArr)
Next ixArr
Application.ScreenUpdating = True
End Sub
Greetz Renee