Pivot, VBA oder Formel? von einen Blatt in zwei andere einfügen und summieren.

[Niko]

Alles was ich im Arbeitsplatt "Manula Input" eintrage, soll in die jeweiligen Blätter Market X und Market Y automatisch übertragen werden.
Auch wenn Market mit Location und Vendor zwei mal erscheint.
Diese sollten in den anderen Blättern zusammegezählt werden können.
So 100% prozentig wie es funktionieren könnte kann ich mir nicht so ganz fertig vorstellen...glaube das es vieleicht mit Pivot gut zu bewerkstelligen wäre, doch ich habe erhrlich kein Clou wie ich das bewerkstelligne könnte. Vieleicht gibt es da eine einfache lösung mit Formeln....naja hoffe das einige hilfe kommt, sthe gerade voll auf der leitung.

Anbei die Datei:
  EXP Test_TEST-2.xlsm (Größe: 27,08 KB / Downloads: 9)


Danke,

Niko  

[Niko]

Jeder Lösungsvorschlag in jeder Richtung Pivot, VBA oder Formeln ist herzlich willkommen.

Danke,
Niko

[Gast 123]

Hallo

da gibt es noch fehlende Infos, die sollten wir wissen bevor man damit anfangen kann. Ich verweise auf die Tabellen in Market X+Y
Dort gibt es Vendor A+B, mit Spalte 1-3.   Woher wissen wir bitte welche Daten in welche Spalten sollen???  1,2 oder 3??  Das ist mir noch unklar.

mfg gast 123

---

Nachtrag   nebeneinander schreiben geht ja auch nicht, dann würde Shipping jedesmal überschreieben. Und was ist mit den Spalten die es in  "Manula Input" garnicht gibt??  Ich sehe im Beispiel Total und zwei mal Express. Wo kommt die Expreess Info her???

[Niko]

So jetzt habe ich es ein bisschen aufgearbeitet und soweit möglich es von meiner Seite ist in der Arbeitsmappe das Beispiel ausführlicher erklärt. 

Weiß nicht ob dies mit Pivot, VBA oder Formeln zu bewältigen ist…doch jeder art von Lösung ist willkommen.

Anbe die Datei mit dem Beispiel:
  EXPENSES_TEST.xlsm (Größe: 26,81 KB / Downloads: 5)

Danke nochmals allen für Ihre Geduld und Verständnis.

Niko

[Gast 123]

Hallo Niko

weil schon ein Target Makro in der Tabelle "Manula Input" exisitert brauchst du diesen Code nur darunter kopieren.  Bin gespannt ob alles einwandfrei funktioniert ...
Wenn das Market Blatt voll ist kommt eine Warnmeldung das nicht mehr weiter kopiert werden kann. Bei doppelter ID Nummer (schon vorhanden)  wird auch nicht kopiert.

mfg Gast 123

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Sht As Variant, lzX As Long
Dim Txt As String, rFind As Range
    If InStr(Target.Address, ":") Then Exit Sub
   
    Sht = Cells(Target.Row, 1).Value
    Sht = Replace(Sht, " ", "")   '** Space Korrektur
    If Sht = Empty Then Exit Sub

    'Vorprüfung ob ID bereits vorhanden ist?
    If Not Intersect(Target, Range("E:E")) Is Nothing Then
       Set rFind = Worksheets(Sht).Columns(4).Find(Target)
       If Not rFind Is Nothing Then GoTo fmd1
    End If
   
    If Not Intersect(Target, Range("H:H")) Is Nothing Then
       Txt = Cells(Target.Row, 4).Value  'Suchtext
       Set rFind = Worksheets(Sht).Columns(4).Find(Txt)
       If Not rFind Is Nothing Then GoTo fmd1
      
       'LastZell in MarketXY suchen  (mit Fehlermeldung)
       lzX = Worksheets(Sht).Range("A1").End(xlDown).Row + 1
       If Worksheets(Sht).Range("A2") = "" Then lzX = 2
       If Worksheets(Sht).Cells(lzX, 1) = "Grand Total" Then GoTo fmd2
      
       Cells(Target.Row, 2).Resize(1, 7).Copy
       Worksheets(Sht).Cells(lzX, 1).PasteSpecial xlPasteValues
       Application.CutCopyMode = False
      
       'Warnung beim letzten Eintrag das market voll ist!
       If Worksheets(Sht).Cells(lzX + 1, 1) = "Grand Total" Then GoTo fmd3
    End If
Exit Sub

'Fehlermeldungen:
fmd1: MsgBox Sht & " - diese ID Nummer exisitiert bereits!": Exit Sub
fmd2: MsgBox Sht & " - das Blatt ist voll, kann nicht mehr kopieren!", vbInformation: Exit Sub
fmd3: MsgBox Sht & " - letzer Eintrag, das Blatt ist voll, kann nicht weiter kopieren!"
End Sub

[Niko]

Vielen Dank für deine Mühe und Zeit.
 
Habe versucht es laufen zu lassen, ohne Resultat leider.
Vielleicht mache ich da was falsch, aber bei mir funktioniert es nicht…es tut sich eigentlich nichts.




Danke,

Niko      

[Gast 123]

Hallo Niko

Sorry, ich habe vergessen dir das Makro zu erklaeren. Es funktioniert über die Target Eingabe!

In der Spalte ID Nummer findet eine Vorprüfung statt ob diese Nummer bereits exisitiert! Dann kommt Fehlermeldung. Das Makro löst erst den kopiervorgang aus wenn du in Spalte H einen Wert eingibst.  Sollte das nicht immer der Fall sein aendern wir das Makro das du da "aa" eingibst und ich lösche es vor dem kopieren weg. Unten habe ich das Makro erweitert.

Teste es bitte noch einmal, jetzt weisst du ja wie die Funktion gedacht ist. Man kann im Eingbeblatt noch ein Merkspalte mit "ok" einfügen ob diese Zeile gebucht wurde.

mfg Gast 123

Code:

       '"aa" Eingabe wenn ein Wert fehlt (wird gelöscht)
       If Target.Value = "aa" Then Target.Value = Empty
       Cells(Target.Row, 2).Resize(1, 7).Copy
       Worksheets(Sht).Cells(lzX, 1).PasteSpecial xlPasteValues
       Application.CutCopyMode = False

[Niko]

Irgendwie klappt es nicht, habe noch mal die Datei mit dem Code eingefügt.
Vielleicht ist es mit Pivot einfacher…oder ich mache hier etwas falsch !...was leider wahrscheinlich sein könnte  .
 

Da war doch was mit Pivot!....obwohl ich bin für jeden Lösungsvorschlag sehr dankbar  


Anbei die Datei: 
  EXPENSES_TEST.xlsm (Größe: 29,61 KB / Downloads: 4)


Danke,
Niko 

[Gast 123]

Hallo

Der Codeteil war an der falschen Stelle eingefügt. Dort konnte es nicht klappen. Ich habe ihn noch mal korrigiert. Unten der komplette Code.
Aus einem mir unbekannten Grund kannn es passieren das die auslösenden Events abgeschaltet sind. Dafür habe ich ein  Startmakro eingebaut um sie ggf. wieder zu aktivieren. Es steht ganz oben im Code.

mfg Gast 123

Code:

Option Explicit

Sub Events_starten()
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
'Me.Unprotect ("1234")

    If Not Intersect(Target, Range("D2:D52")) Is Nothing Then
        Target = IIf(Target = "", Date, "")
        Cancel = True
    End If
  
   
    ' If Not Intersect(Target, Range("I4:I18")) Is Nothing Then
     '   Target = IIf(Target = "", "X", "")
     '   Cancel = True
  '  End If
   
'    Me.Protect ("1234")
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Sht As Variant, lzX As Long
Dim Txt As String, rFind As Range
    If InStr(Target.Address, ":") Then Exit Sub
  
    On Error GoTo Fehler
    Sht = Cells(Target.Row, 1).Value
    Sht = Replace(Sht, " ", "")   '** Space Korrektur
    If Sht = Empty Then Exit Sub
   
    'Vorprüfung ob ID bereits vorhanden ist?
    If Not Intersect(Target, Range("E:E")) Is Nothing Then
       Set rFind = Worksheets(Sht).Columns(4).Find(Target)
       If Not rFind Is Nothing Then GoTo fmd1
    End If
  
    If Not Intersect(Target, Range("H:H")) Is Nothing Then
       Txt = Cells(Target.Row, 5).Value  'Suchtext
       Set rFind = Worksheets(Sht).Columns(4).Find(Txt)
       If Not rFind Is Nothing Then GoTo fmd1
       Application.ScreenUpdating = False
     
       'LastZell in MarketXY suchen  (mit Fehlermeldung)
       lzX = Worksheets(Sht).Range("A1").End(xlDown).Row + 1
       If Worksheets(Sht).Range("A2") = Empty Then lzX = 2
       If Worksheets(Sht).Cells(lzX, 1) = "Grand Total" Then GoTo fmd2
     
       If Target.Value = "aa" Then Target.Value = Empty
       Cells(Target.Row, 2).Resize(1, 7).Copy
       Worksheets(Sht).Cells(lzX, 1).PasteSpecial xlPasteFormats
       Worksheets(Sht).Cells(lzX, 1).PasteSpecial xlPasteValues
       Application.CutCopyMode = False
       Application.EnableEvents = True
       Cells(Target.Row + 1, 1).Select
      
       'Warnung beim letzten Eintrag das market voll ist!
       If Worksheets(Sht).Cells(lzX + 1, 1) = "Grand Total" Then GoTo fmd3
    End If
Exit Sub

'Fehlermeldungen:
fmd1: MsgBox Sht & " - diese ID Nummer exisitiert bereits!": Exit Sub
fmd2: MsgBox Sht & " - das Blatt ist voll, kann nicht mehr kopieren!", vbInformation: Exit Sub
fmd3: MsgBox Sht & " - letzer Eintrag, das Blatt ist voll, kann nicht weiter kopieren!"
Fehler: MsgBox "unerwarteter Target Fehler"
End Sub

---

Nachtrag   mit Pivot habe ich nie gearbeitet, da kann ich nicht weiterhelfen. Ich hoffe ein Kollege kann dir dazu Rat geben.

[schauan]

Hallöchen,

nur mal allgemein, unabhängig vom konkreten Fall:

Aus einem mir unbekannten Grund kann es passieren das die auslösenden Events abgeschaltet sind.

ich würde die Events bei _Change bevorzugt deaktivieren, um einen Mehrfachdurchlauf des Makros zu vermeiden. Natürlich kann es dann Probleme geben, wenn das Makro abgebrochen wird, z.B. bei Fehlern und fehlender Fehlerbehandlung.