MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 09.02.2019, 12:49   #1
Excel Flo
Neuer Benutzer
Neuer Benutzer
Standard VBA - Bereich Copy/Paste anhand Suchkriterium

Hallo liebe Community,

ich habe mich vor kurzem dazu entschlossen in VBA einzusteigen. Einfache Programmierung wie zum Beispiel eine Zelle anwählen, ausschneiden und an anderer Stelle einfügen, sind meine ersten Schritte gewesen.

Nun möchte ich, auch im Hinblick auf die Arbeit, nach einem Begriff suchen und die darunter gelisteten Werte kopieren und einfügen.

Hierzu eine Beispieldatei im Anhang.

Erläuterung: In Tabelle1(Overview), Zelle B2 steht der Suchbegriff. Der gesuchte Begriff soll nun in Tabelle2(Daten) in Zeile 1 gesucht werden und bei einem Treffer, die darunter gelisteten Daten, in den sich in Tabelle1 befindlichen Kasten Schlüsselkosten kopiert/eingefügt werden.

Ich habe mich schon im Netz umgeguckt und ähnliches gefunden.

Nur brauche ich zum besseren Verständnis etwas Anleitung anhand der Tabelle im Anhang.

Ich freue mich, sollte jemand bemühen mir zu helfen und bedanke mich im Voraus.

Gruß und ein schönes Restwochenende

Florian
Angehängte Dateien
Dateityp: xlsx Beispiel.xlsx (10,7 KB, 7x aufgerufen)
Excel Flo ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.02.2019, 12:58   #2
R J
MOF Meister
MOF Meister
Standard

Hi Florian,

da Du ja lernen willst, befass Dich mal mit Find.

__________________

Ciao, Ralf

Kommt mir irgendwie bekannt vor...
Auf, zum Markplatz der Ideen!
Der sicherste Ansatz für einen Irrtum ist der Glaube, alles im Griff zu haben.
Nur, weil ich den Recorder bedienen kann, macht mich das noch lange nicht zum Musiker.


R J ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.02.2019, 13:07   #3
Werner.M
MOF User
MOF User
Standard

Hallo Florian,

und warum unbeding VBA und nicht mit WVERWEIS-Formel?
PHP-Code:

=WENN(WVERWEIS($B$2;Daten!$B$1:$C$12;ZEILE()-3;FALSCH)=0;"";WVERWEIS($B$2;Daten!$B$1:$C$12;ZEILE()-3;FALSCH)) 
Gruß Werner
Werner.M ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.02.2019, 13:43   #4
aloys78
MOF Meister
MOF Meister
Standard

Hallo Florian,

da es VBA sein soll, ein Vorschlag mit Application.Match anstelle von Find.
Code gehört im VBE zum Blatt "Overview".
Auslöser ist die Eingabe des Suchbegriffs in B2.

Gruß
Aloys

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long       ' Zeilen#
    Dim c As Long       ' Spalten#
    Dim erg As Variant  ' Ergebnis Match
    Dim LRow As Long    ' Nr letzte Zeile
    Dim LCol As Long    ' Nr letzte Spalte
    
    If Target.Address(0, 0) <> "B2" Then Exit Sub
    
    With Worksheets("Daten")
        LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        erg = Application.Match(Target, .Range(.Cells(1, "B"), .Cells(1, LCol)), 0)
        If IsNumeric(erg) Then
            c = erg + 1
            LRow = .Cells(Rows.Count, c).End(xlUp).Row
            .Range(.Cells(2, c), .Cells(LRow, c)).Copy Worksheets("Overview").Range("C5")
        Else
            MsgBox "Sucbegriff nicht gefunden !", vbExclamation
        End If
    End With


End Sub
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.02.2019, 14:51   #5
Excel Flo
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

@ Ralf

Vielen Dank für deine Antwort und den Hinweis mit Find. Werde ich mich mal mit befassen.

@Werner

Dir natürlich auch vielen Dank. Super Lösung. An WVERWEIS habe ich gar nicht gedacht
Excel Flo ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.02.2019, 14:57   #6
Excel Flo
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Zitat: von aloys78 Beitrag anzeigen

Hallo Florian,

da es VBA sein soll, ein Vorschlag mit Application.Match anstelle von Find.
Code gehört im VBE zum Blatt "Overview".
Auslöser ist die Eingabe des Suchbegriffs in B2.

Gruß
Aloys

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long       ' Zeilen#
    Dim c As Long       ' Spalten#
    Dim erg As Variant  ' Ergebnis Match
    Dim LRow As Long    ' Nr letzte Zeile
    Dim LCol As Long    ' Nr letzte Spalte
    
    If Target.Address(0, 0) <> "B2" Then Exit Sub
    
    With Worksheets("Daten")
        LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        erg = Application.Match(Target, .Range(.Cells(1, "B"), .Cells(1, LCol)), 0)
        If IsNumeric(erg) Then
            c = erg + 1
            LRow = .Cells(Rows.Count, c).End(xlUp).Row
            .Range(.Cells(2, c), .Cells(LRow, c)).Copy Worksheets("Overview").Range("C5")
        Else
            MsgBox "Sucbegriff nicht gefunden !", vbExclamation
        End If
    End With


End Sub

Hallo Aloys,

vielen Dank für deine Code Lösung. Echt super.

Das einzige Problem was ich dabei hätte ist, wenn beim nächsten Suchbegriff die Anzahl der Schlüsselkosten geringer ist als vorherigen, bleiben die nicht dem Suchbegriff zugeordneten stehen.

Gruß
Florian
Excel Flo ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.02.2019, 15:10   #7
Werner.M
MOF User
MOF User
Standard

Hallo,

und dann noch mit Find.
Der Zielbereich wird vorher geleert.
PHP-Code:

Option Explicit

Public Sub Suchen_kopieren()
Dim strSuche As StringraFund As RangeloLetzte As Long

strSuche 
Worksheets("Overview").Range("B2")

If 
Not strSuche vbNullString Then
    With Worksheets
("Daten")
        
Set raFund = .Rows(1).Find(what:=strSucheLookIn:=xlValueslookat:=xlWhole)
        If 
Not raFund Is Nothing Then
            Worksheets
("Overview").Range("C5:C15").ClearContents
            loLetzte 
= .Cells(.Rows.CountraFund.Column).End(xlUp).Row
            
.Range(.Cells(2raFund.Column), .Cells(loLetzteraFund.Column)).Copy
            Worksheets
("Overview").Range("C5").PasteSpecial Paste:=xlPasteValues
            Application
.CutCopyMode False
        
Else
            
MsgBox "Suchbegriff " strSuche " nicht vorhanden."
        
End If
    
End With
End 
If
        
End Sub 
Gruß Werner
Werner.M ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.02.2019, 16:52   #8
aloys78
MOF Meister
MOF Meister
Standard

Hallo Florian,

Zitat:

Das einzige Problem was ich dabei hätte ist, wenn beim nächsten Suchbegriff die Anzahl der Schlüsselkosten geringer ist als vorherigen, bleiben die nicht dem Suchbegriff zugeordneten stehen.

Dieses Problem ist in der neuen Version gelöst.

Gruß
Aloys
Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r As Long       ' Zeilen#
    Dim c As Long       ' Spalten#
    Dim erg As Variant  ' Ergebnis Match
    Dim LRow As Long    ' Nr letzte Zeile
    Dim LCol As Long    ' Nr letzte Spalte
    
    If Target.Address(0, 0) <> "B2" Then Exit Sub
    
    With Worksheets("Daten")
        LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        erg = Application.Match(Target, .Range(.Cells(1, "B"), .Cells(1, LCol)), 0)
        If IsNumeric(erg) Then
            LRow = Me.Cells(Rows.Count, "C").End(xlUp).Row
            Application.EnableEvents = False
            Me.Range("C5:C" & LRow).ClearContents
            c = erg + 1
            LRow = .Cells(Rows.Count, c).End(xlUp).Row
            .Range(.Cells(2, c), .Cells(LRow, c)).Copy Me.Range("C5")
            Application.EnableEvents = True
        Else
            MsgBox "Sucbegriff nicht gefunden !", vbExclamation
        End If
    End With
End Sub
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 10:32   #9
Excel Flo
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo zusammen,

nochmals vielen Dank an alle. Klasse Leute hier. Das hilft mir wirklich sehr.

Wie verhält es sich denn, wenn ich pro Suchbegriff, mehrere Spalten habe?

Da scheitere ich momentan

Könnte mir dabei jemand helfen?

Ich habe die Tabelle im Anhang erweitert.

Gruß
Florian
Angehängte Dateien
Dateityp: xlsm Beispiel.xlsm (18,7 KB, 3x aufgerufen)

Geändert von Excel Flo (11.02.2019 um 10:35 Uhr).
Excel Flo ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 19:31   #10
Excel Flo
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Zitat: von Excel Flo Beitrag anzeigen

Hallo zusammen,

nochmals vielen Dank an alle. Klasse Leute hier. Das hilft mir wirklich sehr.

Wie verhält es sich denn, wenn ich pro Suchbegriff, mehrere Spalten habe?

Da scheitere ich momentan

Könnte mir dabei jemand helfen?

Ich habe die Tabelle im Anhang erweitert.

Gruß
Florian

Sei noch erwähnt,dass das Blatt "Daten", nun 3 Spalten pro Suchbegriff hat.

Und gleich mal die richtige Datei angehängt. Sorry
Angehängte Dateien
Dateityp: xlsm Beispiel.xlsm (20,3 KB, 5x aufgerufen)

Geändert von Excel Flo (11.02.2019 um 19:37 Uhr).
Excel Flo ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 11.02.2019, 21:25   #11
Werner.M
MOF User
MOF User
Standard

Hallo,

so:
PHP-Code:

Option Explicit

Public Sub Suchen_kopieren()
Dim strSuche As StringraFund As RangeloLetzte As Long

strSuche 
Worksheets("Overview").Range("B2")

If 
Not strSuche vbNullString Then
    With Worksheets
("Daten")
        
Set raFund = .Rows(1).Find(what:=strSucheLookIn:=xlValueslookat:=xlWhole)
        If 
Not raFund Is Nothing Then
            Worksheets
("Overview").Range("B5:D15").ClearContents
            loLetzte 
= .Cells(.Rows.CountraFund.Column).End(xlUp).Row
            
.Range(.Cells(2raFund.Column), .Cells(loLetzteraFund.Column 2)).Copy
            Worksheets
("Overview").Range("B5").PasteSpecial Paste:=xlPasteValues
            Application
.CutCopyMode False
        
Else
            
MsgBox "Suchbegriff " strSuche " nicht vorhanden."
        
End If
    
End With
End 
If
         
End Sub 
Gruß Werner
Werner.M ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 09.04.2019, 11:04   #12
Homer_
Neuer Benutzer
Neuer Benutzer
Standard

Hallo liebes Forum,

ich bin auf dieses Thema hier gestoßen, da ich ein ähnliches Problem habe.
Die Posts hier haben mir schon mal sehr geholfen.

Mein Aufbau in der hier hochgeladenen Datei ist ähnlich.

Nur habe ich für einen Begriff mehrere zugehörige Tabellen die untereinander angeordnet sind.

Meine Frage, wie müsste ich den Code umstellen, so das nur ein bestimmter Bereich (entsprechend des Suchbegriffes) kopiert und eingefügt wird?


Da harderts noch bei mir

Vielen Dank im Voraus für Hilfe
Homer_ ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 10.04.2019, 10:23   #13
Homer_
Neuer Benutzer
Neuer Benutzer
Standard

Ich formuliere meine Frage mal anders.

Der gesuchte Begriff, befindet sich in der ersten Zeile des Blattes "Daten". Mit dem hier geposteten Code wird ja bei einem Treffer bis zur letzten aktiven Zeile kopiert.

Ich möchte aber nur einen bestimmten Bereich kopieren.
Angehängte Dateien
Dateityp: xlsm Beispiel.xlsm (18,6 KB, 1x aufgerufen)
Homer_ ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 08:48 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.