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: [
attachment=37820]
Danke,
Niko
Jeder Lösungsvorschlag in jeder Richtung Pivot, VBA oder Formeln ist herzlich willkommen.
Danke,
Niko
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???
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: [
attachment=37830]
Danke nochmals allen für Ihre Geduld und Verständnis.
Niko
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
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
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
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: [
attachment=37838]
Danke,
Niko
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.
Hallöchen,
nur mal allgemein, unabhängig vom konkreten Fall:
Zitat: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.