Office 2010: VBA: Finden_Kopieren

[joerg88]

Hallo zusammen,

ich bin blutiger Anfänger hinsichtlich VBA und habe noch nie eine Makro geschrieben. Leider stehe ich aktuell total auf dem Schlauch und weiß nicht wie ich meinen Code zu schreiben habe.

In Tabelle 2 finden sich ab Spalte B3 eine Mischung aus Zahlen-/ Buchstabencodes, welche als Suchkriterien dienen. Die Makro soll jeden einzelnen Wert nehmen und ihn mit den Rohdaten in Tabelle 1 vergleichen. Jedes Suchkriterium kommt in Spalte E (Tabelle 1) mehrfach vor, sodass hier eine Schleife nötig ist. Wenn also eine Übereinstimmung gefunden wurde, soll die komplette Zeile (A:M) kopiert werden und in Tabelle 3 (ab Zeile 2) eingefügt werden. Sofern dann alle Zeilen mit dem jeweiligen Code in den Output kopiert wurden, soll die ganze Prozedur mit dem nächsten Suchkritierium (aus Tabelle 2; Spalte E) wieder von vorne beginnen, bis auch der letzte Code (aus Tabelle 2) durch Tabelle 1 gelaufen ist und die Daten in Tabelle 3 ausgespuckt wurden.

Besten Dank schonmal

[gmg-cc]

Moin Joerg,
können in Sheet2 (Suche) die Suchkriterien mehrfach vorkommen? Wenn nein, dann solltest du einmal in der auszuwertenden Tabelle einen Filter setzen und alles Sichtbare kopieren. Diesen Vorgang zeichnest du mit dem Makrorecorder auf. Danach de Code etwas bereinigen (Select, Activate raus) und dann per Schleife alle Positionen der Such-Liste abarbeiten.

Wenn du die Grundlagen gelegt hast, helfen wir dir hier gerne weiter. DieDatei ist dazu allerdings erforderlich ...

[joerg88]

Moin Günther,
merci für deine Antwort.

Die Suchkriterien im Sheet2 kommen nur einmal vor, was den Code sicherlich vereinfachen sollte. Ich habe mich heute Nachmittag mal an die Makro gesetzt, bin mit meinem Latein aber nun am Ende. Vllt. kannst du mit meinem Script ja etwas anfangen und mir weiterhelfen.
By the way: Das File ist leider zu groß, weshalb ich einige Zeilen gelöscht habe und nur einen kleinen Auszug (hinsichtlich der Rohdaten& Suchkriterien) hochgeladen habe. Deshalb arbeite ich auch mit der Funktion letzteZeile ...

Dank & Gruß
Jörg

[gmg-cc]

Moin Jörg,

du bist neu in Foren und auch in Sachen VBA. Darum sind die Hinweise Hilfestellungen und keine "Meckereien".
Musterdatei ist gut, aber es reiche normalerweise maximal 100 Zeilen.
Ich habe deinen Code mächtig aufgeräumt (Dein Original-Code ist auskommentiert):

Code: [Auswählen]

'Sub FindenUndKopieren()
'
'Dim letzteZeile As Double
'Dim letzteZeile2 As Double
'Dim Zielzeile As Double
'Dim Zielspalte As Double
'Dim ZielPNR As String
'
'Application.ScreenUpdating = True
'
'ActiveWorkbook.Worksheets("Rohdaten").Select
'
'    With ActiveSheet
'
'        letztZeile = .Cells(Rows.Count, 1).End(xlUp)
'
'    End With
'
'    'MsgBox letzteZeile
'
'ActiveWorkbook.Worksheets("PNR").Select
'
'    With ActiveSheet
'
'        letzteZeile2 = .Cells(Rows.Count, 2).End(xlUp)
'
'    End With
'
'    'MsgBox letzteZeile2
'
'Zielzeile = 5
'
'    Zielspalte = 2
'
'    ZielPNR = ActiveWorkbook.Worksheets("PNR").Cells(i, 2)
'
'    ActiveWorkbook.Worksheets("Output").Cells(Zielzeile, 1) = ZielPNR
'
'        For k = 2 To 13
'
'        ActiveWorkbook.Worksheets("Rohdaten").Select
'        ActiveWorkbook.Worksheets("Rohdaten").Cells(j, k).Select
'        Selection Copy
'        ActiveWorkbook.Worksheets("Output").Select
'        ActiveWorkbook.Worksheets("Output").Cells(Zielzeile, Zielspalte).Select
'        ActiveSheet.Paste
'
'        Zielspalte = Zielspalte + 1
'
'        Next
'
'        Zielzeile = Zielzeile + 1
'
'
'Next
'
'Next
'
'Application.ScreenUpdating = True
'
'End Sub

'####################################################################################
Option Explicit

Sub FindenUndKopieren()
    Dim letzteZeile As Long     'Geändert
    Dim letzteZeile2 As Long    'Geändert
    Dim Zielzeile As Long       'Geändert
    Dim Zielspalte As Long      'Geändert
    Dim ZielPNR As String
    Dim wksRoh As Worksheet, wksPNR As Worksheet, wksOutput As Worksheet
    Dim i As Long, j As Long, k As Long
   
    Application.ScreenUpdating = False  'Geändert
    Set wksRoh = Worksheets("Rohdaten")
    Set wksPNR = Worksheets("PNR")
    Set wksOutput = Worksheets("Output")
    letzteZeile = wksRoh.Cells(Rows.Count, 1).End(xlUp).Row
    letzteZeile2 = wksPNR.Cells(Rows.Count, 2).End(xlUp).Row
    Zielzeile = 5
    Zielspalte = 2
   
    'Irgendwie fehlt hier eine Schleife: For I = 1 To ???, darim per Hand initialisiert
    'Gilt auch für j, darum habe ich dann auch die beiden NEXT unten deaktivieren müssen
    i = 1
    j = 1
    ZielPNR = wksPNR.Cells(i, 2)
    wksOutput.Cells(Zielzeile, 1) = ZielPNR
   
'    For k = 2 To 13
'        wksRoh.Cells.Cells(j, k).Copy wksOutput.Cells(Zielzeile, Zielspalte)
'        Zielspalte = Zielspalte + 1
'    Next k
    ' Na gut, das ist die geküzte Langform mit Schleife
    ' Meine Variante (falls ich die Positionierung in Output richtig verstanden habe:
    wksRoh.Range("B1:M1").Copy
    wksOutput.Range("A5:L5").PasteSpecial xlPasteValues
   
    Zielzeile = Zielzeile + 1
    'Next
    '
    'Next
    Application.ScreenUpdating = True
End SubVersuche, die Kommentare zu verstehen und auch den geänderten Code. Diese ganze Select-Arie ist einfach unnötig, wie du siehst. Das brmst nur aus, auch wenn der Makrorecorder das mit aufzeichnet.

Wenn du das erarbeitet hast, mache aus den Rohdaten per Strg+T eine Tabelle.
Dann zeichnest du den folgenden Code auf:

Code: [Auswählen]

Filter in Spalte E setzen
Strg+Pos1
Strg+CursorDown
Strg+A
Strg+C
Wechsel zu Output
Inhalt einfügen als Wert
Zurück zu Rohdaten
Filter entfernen (alle anzeigen)

Überarbeite dann noch einmal den oben stehenden Code und füge den aufgezeichneten Code ein. Vielleicht sogar etwas nachgearbeitet. Und das stellst du uns dann hier vor ...

[joerg88]

Hallo Günther,

ich bin ja froh über jede Hilfe und da sind deine Hinweise eine super Hilfe. Deinen Code habe ich jedenfalls verstanden, was auch an der viel leichteren Struktur liegt.

Wenn ich die bisherige Makro laufen lasse, wird mir nichtsdestotrotz der folgende Fehler angezeigt:

Laufzeitfehler ‘438:
Objekt unterstützt diese Eigenschaft oder Methode nicht.

Code: [Auswählen]

Option Explicit
 
Sub FindenUndKopieren()
 
Dim letzteZeile As Long
Dim letzteZeile2 As Long
Dim Zielzeile As Long
Dim Zielspalte As Long
Dim ZielPNR As String
Dim wksRoh As Worksheet, wksPNR As Worksheet, wksOutput As Worksheet
Dim i As Long, j As Long, k As Long
 
    Application.ScreenUpdating = False
   
Set wksRoh = Worksheets("Rohdaten")
Set wksPNR = Worksheets("PNR")
Set wksOutput = Worksheets("Output")
letzteZeile = wksRoh.Cells(Rows.Count, 1).End(xlUp).Row
letzteZeile2 = wksPNR.Cells(Rows.Count, 2).End(xlUp).Row
Zielzeile = 5
Zielspalte = 2
i = 1
j = 1
 
   
    wksRoh.Range("B1:M259192").Copy
    wksOutput.Range("A5:L5").PasteSpecialxlPasteValues
   
    Zielzeile = Zielzeile + 1
   
    Application.ScreenUpdating = False
   
End Sub

Ansonsten habe ich deinen Tipp mit dem Makrorecorder umgesetzt. Dabei kam der folgende Code raus:

Code: [Auswählen]

Sub Makro9()
'
' Makro9 Makro
'
 
'
    Range("Tabelle2[[#Headers],[AMD_RECORD_LC_CODE]]").Select
    Selection.AutoFilter
    Sheets("PNR").Select
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "29RT5J"
    Sheets("Rohdaten").Select
    ActiveSheet.ListObjects("Tabelle2").Range.AutoFilter Field:=5, Criteria1:= _
        "29RT5J"
    Range("E131277").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range("Tabelle2").Select
    Range("E131277").Activate
    Selection.Copy
    Sheets("Output").Select
    Range("A5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A11").Select
    Sheets("Rohdaten").Select
    ActiveSheet.ListObjects("Tabelle2").Range.AutoFilter Field:=5
End Sub

Wäret du vllt. so freundlich mir wieder zu helfen, oder gar die gesamte Makro zu schreiben?

Dank und Gruß
Jörg