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, 13: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, 5x 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, 13: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, 14: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, 14: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, 15: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, 15: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, 16: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, 17: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, 11: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, 2x aufgerufen)

Geändert von Excel Flo (11.02.2019 um 11: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, 20: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, 2x aufgerufen)

Geändert von Excel Flo (11.02.2019 um 20: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, 22: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
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 21:21 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

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.