VBA ,Inhalt einer Masnahmenliste kopieren

[Tommiks]

Hallo zusammen,
 
bevor ich mich an Euch gewendet habe, habe ich mehrere Stunden gegoogelt. Aber ich komme nicht mehr weiter....
 
Die Datei füge ich hinzu.
 
Ich muss in der Datei nur "Ursache Ausbringung"-Zeilen kopieren. dafür habe ich ein Skript gefunden. Es funktioniert zum Teil gut.
Was mir fehlt, ist die Abteilung der kopierten Zeile und das Datum der kopierten Zeile.
 
Wie könnte man das Skript erweitern? Danke.

[ralf_b]

PHP-Code:

'oben noch 
dim x

'3b) Kopiere die Quellzeile in die Zielzeile, beginnend in Spalte A von Zeilennr. "rngZeile":
              
              Ws.Rows(2).Copy Destination:=Me.Cells(lngZeile, 1) 'datumszeile einfügen
              lngZeile = lngZeile + 1
              rngZelleX.EntireRow.Copy Destination:=Me.Cells(lngZeile, 1)
              
              'schleife für Abteilung               
              For Each x In Array(152, 136, 121, 105, 89, 70, 54, 38, 20, 4)
                    If rngZelleX.Row > x Then
                        Me.Cells(lngZeile, 1) = Ws.Cells(x, 2).Value
                        Exit For
                    End If
               Next
            
 '4a) Suche nach dem nächsten "x"-Wert in Spalte J; 


[d'r Bastler]

Moin Tommiks,

ich habe mir Deine Tabelle eben angeschaut und einen selten liebevoll kommentierten Code gefunden WOW!!

Um Deine Frage zu verstehen, versuche ich mal umzuformulieren:
Wenn Du in den Daten der Abteilung X in der Zeile Ursache Ausbringung einen Doppelklick machst, sollen folgende Informationen in die Zusammenfassung übertragen werden:

• Die gesamte Zeile
  
• Das Datum aus der Spalte
  
• Der Abteilungsname
  

Korrekt?

Dann habe ich da mal was vorbereitet ...


  Mappe1.txt (Größe: 18,28 KB / Downloads: 1) umbenennen in .xlsb

Schöne Grüße

p.s. Die Kommentare reiche ich später nach... Jetzt habe ich Hunger

[d'r Bastler]

Code:

Option Explicit
'm Bastler sein Code gehört in JEDE der KW-Tabellen!
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim wsA As Worksheet, wsZ As Worksheet                                                      'das jeweils aktive Arbeitsblatt und die Zusammenfassung
Dim i As Integer, z As Integer, s As Integer, sa As Integer, zn As Integer, iPos As Integer 'ein paar Zähler für Schleifen und Zeilen/Spalten in den verschiedenen Arbeitsblättern
Dim sDatum As String, sAbteilung As String, sFilter As String, sKeyword As String           'Texte, die als Wert oder Filter dienen

'die Objekte Worksheet mit Werten füllen
Set wsA = ActiveSheet
Set wsZ = Sheets("Zusammenfassung")

'die Zähler mit Werten füllen
z = Target.Row                                                      'die Zeilennummer der aktiven Zelle
s = Target.Column                                                   'die Spaltennummer der aktiven
sa = wsA.UsedRange.Columns.Count                                    'zählt die im Aktiven Arbeitsblatt gefüllten Spalten
zn = wsZ.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1         'zählt die in der Zusammenfassung gefüllten Zeilen und erhöht um 1 (Ziel also unter den vorhandenen Einträgen)

'die Filterbegriffe definieren
sFilter = wsZ.Cells(1, 1)                                           'durch das Füllen des Filters aus einer Zelle, kann die Prozedur schnell angepasst werden
sKeyword = "Abt"                                                    'hier die Alternative hart-codiert

If wsA.Cells(z, 1) = sFilter Then                                   'Ausführen nur wenn der Filterbegriff in in Spalte A der aktiven Zeile steht
    sDatum = Cells(1, s)                                            'holt das Datum aus der aktiven Spalte
   
    For i = z To 1 Step -1                                          'sucht per Schleife ab der aktiven Zeile nach oben
        iPos = InStr(1, Cells(i, 1), sKeyword)                      'nach dem Keyword
        If iPos <> 0 Then                                           'wenn gefunden dann
            sAbteilung = Cells(i, 1)                                'die Abteilung in sAbteilung schreiben
            GoTo weiter                                             'und die Schleife verlassen
        End If
    Next i                                                          'nicht gefunden? also weiter in der Schleife
   
weiter:                                                             'Keyword gefunden, sAbteilung gefüllt - alles gut!
    wsZ.Cells(zn, 1) = sAbteilung                                   'Kopiert die Abteilung in die erste freie Zeile der Zusammenfassung Spalte 1
    wsZ.Cells(zn, 2) = sDatum                                       'Kopiert das datum in die erste freie Zeile der Zusammenfassung Spalte 2
    Range(wsA.Cells(z, 1), wsA.Cells(z, sa)).Copy wsZ.Cells(zn, 3)  'Kopiert die gefüllten Zellen in der aktiven Zeile in die erste freie Zeile der Zusammenfassung Spalte 3
   
    MsgBox "Aktion der " & sAbteilung & " am " & sDatum & " kopiert!", , "Zeile " & zn
End If

End Sub

... wie versprochen und etwas verbessert (vergiss die Mappe oben ... , nimm die unten!)

Schönen Abend noch!

[Edit] in der Tabelle Zusammenfassung A1 muss natürlich "Ursache Ausbringung" stehen, sonst passiert nämlich nix.

[d'r Bastler]

Und dann doch noch mal mit Tabelle ...


  Mappe2.txt (Größe: 17,4 KB / Downloads: 5) umbenennen in .xlsb

Grüße!

p.s. 'ne Rückmeldung wäre nett

[Tommiks]

Guten Morgen Dr. Bastler,

vorerst möchte ich mich für deine Mühe bedanken.



[*]Ja, die Tabelle soll

[*]+ die gesamte Zeile

[*]+ Das Datum aus der Spalte

[*]+ Der Abteilungsname


übernehmen.


[*]Ich habe dein Skript mit meinem Skript eins zu eins ausgetauscht. Wie starte ich dein Skript? Denn mein Skript konnte ich in dem Arbeitsblatt "Zusammenfassung" mit einem Doppelklick bei A1 starten.

Vielen Dank...

[ralf_b]

bekomme ich auch eine Info bzgl. meines Vorschlages?

[Tommiks]

Guten Morgen @Ralf_b,


 ich hatte dienen Vorschlag noch nicht umgesetzt, weil ich Copy-Paste einfacher war, aber da das Skript von Dr. Bastler in meiner angehängten originalen Datei nicht funktioniert hat, werde ich mich an dienen Vorschlag wenden.Danke Dir...

---

Hallo @Ralf_b,

bombastisch,

Nur eine Bitte, kann man beim Kopieren der Inhalte die ganzen Farben(Formate) der Inhalte elimieren? Denn die Zusammenfassung soll ohne Schnickschnack zum Ausdrucken sein.Danke....

[d'r Bastler]

Moin Tommiks,

naja, daran gedacht, Dein Script 1:1 zu ersetzen, hatte ich eigentlich nicht, sonder eher Dich mit den detaillierten Kommentaren auf den Weg zur Selbsthilfe zu führen. Dazu wäre es sinnvoll gewesen, den Code etwas genauer in Augenschein zu nehmen, statt nur Copy 'n Paste ...

Das Script wartet auf Doppelklicks in allen Zellen des jeweiligen Sheets, reagiert aber nur dann, wenn das Keyword Ursache Ausbringung in Zelle A1 der Zusammenfassungstabelle und in der aktivierten Zeile im Sheet steht. Wie Du das auch hart-codieren kannst, ist im meinem Code beschrieben. Ich habe ihn so gebaut, dass er auch bei einem Redesign (z.B. alle Werktage eines Jahres in ein Blatt, statt eines pro Woche?) Deiner KW-Tabellen noch funktionieren sollte.

Nachtrag: Meine Zusammenfassung kommt ohne Schnickschnack daher und wenn man die Zelle A1 als Überschrift formatiert, kann man auf die Spalte mit dem Text Ursa... pro Zeile sogar noch verzichten.

Viel Erfolg noch! und schöne Grüße