Makro an veränderte Anforderungen anpassen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: Makro an veränderte Anforderungen anpassen
von: Fritz
Geschrieben am: 26.03.2005 11:06:29
Hallo Excelfreunde,
ich habe hier im Forum das nachstehende Makro gefunden, das ich in einer Arbeitsmappe in veränderter Form verwenden möchte.
Nachfolgende Änderungen würde ich gerne realsieren:
1. In der Input-Box sollte der in der der Quelltabelle "Lagerung" in der
Spalte A in der letzten Zeile eingetragene Wert als voreingetragener Wert
erscheinen.
2. In die Zieltabelle ("Lagerausgang")sollten nur die Spalten A bis F der
Quelltabelle "Lagerung" kopiert werden.
Wäre nett, wenn einer von euch VBA-Spezialisten mir den Code entsprechend anpassen würde.
Für eure Unterstützung vielen Dank im Voraus.
Gruß
Fritz
Hier der Ausgangscode:


Sub wert_kopieren()
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim wert As String, rFind As Range
Dim lrow As Long, i As Long
Dim sFirst As String
Set wks1 = Sheets("Lagerung")
Set wks2 = Sheets("Lagerausgang")
lrow = wks2.Range("A65536").End(xlUp).Row + 1
wert = Application.InputBox("Wert für die Suche eingeben!", "Suche", "212334")
Set rFind = wks1.Range("A:A").Find(what:=wert, LookIn:=xlValues, lookat:=xlWhole)
  If Not rFind Is Nothing Then
    sFirst = rFind.Address
      Do
        rFind.EntireRow.Copy wks2.Cells(lrow, 1)
        Set rFind = wks1.Range("A:A").FindNext(rFind)
        lrow = lrow + 1
      Loop While sFirst <> rFind.Address
  End If
sFirst = vbNullString
Set rFind = Nothing
End Sub

Bild

Betrifft: AW: Makro an veränderte Anforderungen anpassen
von: Hajo_Zi
Geschrieben am: 26.03.2005 11:16:22
Hallo Fritz,
wäre da eine Datei nicht besser gewesen?
Hier mal den ersten Teil
Dim LoLetzte As Long
LoLetzte = IIf(IsEmpty(wks1.Range("A65536")), wks1.Range("A65536").End(xlUp).Row, 65536)
wert = Application.InputBox("Wert für die Suche eingeben!", "Suche", wks1.Cells(LoLetzte, 1))

Bitte keine Mail, Probleme sollten im Forum gelöst werden.
Microsoft MVP für Excel
Das Forum lebt auch von den Rückmeldungen.
Betriebssystem XP Home SP2 und Excel Version 2003 SP1.


Bild

Betrifft: AW: Makro an veränderte Anforderungen anpassen
von: Hajo_Zi
Geschrieben am: 26.03.2005 11:20:08
Hallo Fritz,
zweiter Teil ohne Testung
Range(Cells(rFind.Rows, 1), Cells(rFind.Rows, 6)).Copy wks2.Cells(lrow, 1)
Gruß Hajo
Das Forum lebt auch von den Rückmeldungen.
Bild

Betrifft: AW: Makro an veränderte Anforderungen anpassen
von: Fritz
Geschrieben am: 26.03.2005 11:42:49
Hallo Hajo,
erstmal vielen Dank für Deine Hilfe.
Zu Deiner Frage: "Wäre da eine Datei nicht besser gewesen?".
Wie hast Du das gemeint?
Ich werd heute nachmittag versuchen, deine Vorschläge in den vorhandenen Code "einzubauen". Hoffe, dass ich das hinkrieg.
Mit meinen momentanen Kenntnissen in Sachen VBA ist das eine echte Herausforderung.
Ich werde mich danach hier auf jeden Fall noch einmal melden.
Nochmals danke für die Unterstützung.
Gruß
Fritz
Bild

Betrifft: AW: Makro an veränderte Anforderungen anpassen
von: Hajo_Zi
Geschrieben am: 26.03.2005 11:47:33
Hallo Fritz,
über dem Antwortformular gibt es einen Dialog zum hochladen von Dateien. Du hast die Datei schon anglegt, warum sollte ich dafü die Zeit investieren. Ich teste meinen Code im Forum zu 99% bevor ich ihn hochlade und da wäre eine Datei schon mal nicht schlecht.
Gruß Hajo
Das Forum lebt auch von den Rückmeldungen.
Bild

Betrifft: @Hajo_Z
von: Fritz
Geschrieben am: 26.03.2005 15:03:44
Hallo Hajo,
ich habe mich inzwischen - mit Teilerfolg - an der Umsetzung Deiner Vorschläge versucht.
Die erste Änderung klappt wunderbar. Deinen zweiten Vorschlag allerdings konnte ich mangels meiner unzureichenden VBA-Kenntnisse nicht erfolgreich umsetzen.
Lade Dir deshalb die Datei hoch.
Gruß und schöne Ostertage Dir und allen fleißigen Helfern
Fritz
https://www.herber.de/bbs/user/20179.xls
Bild

Betrifft: Finden mehrmals und copieren
von: Hajo_Zi
Geschrieben am: 26.03.2005 17:10:53
Hallo Fritz,
ich habe mich mal rangesetzt und einen neuen Code erstellt.

Sub Find_mehrmals()
'**************************************************
'* H. Ziplies                                     *
'* 26.03.05                                       *
'* erstellt von Hajo.Ziplies@web.de               *
'* <a href="http://home.media-n.de/ziplies/">http://home.media-n.de/ziplies/</a> *
'**************************************************
    Dim wks1 As Worksheet
    Dim wks2 As Worksheet
    Dim Found As Range
    Dim FirstAddress As String
    Dim Search As String
    Dim LoLetzte1 As Long   ' letzte Zeile Lagerung
    Dim LoLetzte2 As Long   ' letzte Zeile Lagerausgang
    Set wks1 = Sheets("Lagerung")
    Set wks2 = Sheets("Lagerausgang")
    LoLetzte1 = IIf(IsEmpty(wks1.Range("A65536")), wks1.Range("A65536").End(xlUp).Row, 65536)
    LoLetzte2 = IIf(IsEmpty(wks2.Range("A65536")), wks2.Range("A65536").End(xlUp).Row, 65536)
    Search = Application.InputBox("Wert für die Suche eingeben!", "Suche", wks1.Cells(LoLetzte1, 1))
    With wks2
        '   von Peter Haserodt
            Set Found = .Range("A1:A" & LoLetzte2).Find(Search, .Range("A" & LoLetzte2), xlValues, xlWhole, , xlNext)
        '   *****
            If Found Is Nothing Then Exit 

Sub  'falls nicht gefunden wird 

Sub verlassen
            .Range(.Cells(Found.Row, 1), .Cells(Found.Row, 6)).Copy Destination:=wks1.Cells(LoLetzte1 + 1, 1)
            LoLetzte1 = LoLetzte1 + 1
            FirstAddress = Found.Address
            Do
                Set Found = .Range("A1:A" & LoLetzte2).FindNext(Found)
                If Found.Address = FirstAddress Then Exit Sub
                .Range(.Cells(Found.Row, 1), .Cells(Found.Row, 6)).Copy Destination:=wks1.Cells(LoLetzte1 + 1, 1)
                If Found.Row = LoLetzte2 Then Exit Sub
                LoLetzte1 = LoLetzte1 + 1
            Loop While Not Found Is Nothing
    End With
End Sub

Gruß Hajo
Das Forum lebt auch von den Rückmeldungen.
Bild

Betrifft: AW: Finden mehrmals und copieren
von: Fritz
Geschrieben am: 27.03.2005 10:35:35
Hallo Hajo,
ganz toll, dass Du Dir so viel Mühe machst.
Ich habe Dein Makro in die Mappe übernommen.
Beim Testen habe ich eben festgestellt, dass die Daten nicht in die Zieltabelle kopiert werden. Eine (Fehler-)Meldung erscheint aber auch nicht. Lade die Datei deshalb noch einmal hoch. Wäre nett, wenn Du nachprüfen könntest, woran das liegt.
Vielen Dank
Fritz
Bild

Betrifft: Nachtrag
von: Fritz
Geschrieben am: 27.03.2005 13:17:47
Hallo Hajo,
hier ist die Datei mit Makro.
Gruß
Fritz
https://www.herber.de/bbs/user/20202.xls
Bild

Betrifft: AW: Nachtrag
von: Hajo_Zi
Geschrieben am: 27.03.2005 16:08:20
Hallo Fritz,
da bin ich wohl mit den Namen durcheinandergekommen.

Sub Find_mehrmals()
'**************************************************
'* H. Ziplies                                     *
'* 26.03.05                                       *
'* erstellt von Hajo.Ziplies@web.de               *
'* <a href="http://home.media-n.de/ziplies/">http://home.media-n.de/ziplies/</a> *
'**************************************************
    Dim wks1 As Worksheet
    Dim wks2 As Worksheet
    Dim Found As Range
    Dim FirstAddress As String
    Dim Search As String
    Dim LoLetzte1 As Long   ' letzte Zeile Lagerung
    Dim LoLetzte2 As Long   ' letzte Zeile Lagerausgang
    Set wks1 = Sheets("Lagerung")
    Set wks2 = Sheets("Lagerausgang")
    LoLetzte1 = IIf(IsEmpty(wks1.Range("A65536")), wks1.Range("A65536").End(xlUp).Row, 65536)
    LoLetzte2 = IIf(IsEmpty(wks2.Range("A65536")), wks2.Range("A65536").End(xlUp).Row, 65536)
    Search = Application.InputBox("Wert für die Suche eingeben!", "Suche", wks1.Cells(LoLetzte1, 1))
    With wks1
        '   von Peter Haserodt
            Set Found = .Range("A1:A" & LoLetzte1).Find(Search, .Range("A" & LoLetzte1), _
                xlValues, xlWhole, , xlNext)
        '   *****
            If Found Is Nothing Then Exit 

Sub  'falls nicht gefunden wird 

Sub verlassen
            .Range(.Cells(Found.Row, 1), .Cells(Found.Row, 6)).Copy _
                Destination:=wks2.Cells(LoLetzte2 + 1, 1)
            LoLetzte2 = LoLetzte2 + 1
            FirstAddress = Found.Address
            Do
                Set Found = .Range("A1:A" & LoLetzte1).FindNext(Found)
                If Found.Address = FirstAddress Then Exit Sub
                .Range(.Cells(Found.Row, 1), .Cells(Found.Row, 6)).Copy Destination:=wks2.Cells(LoLetzte2 + 1, 1)
                If Found.Row = LoLetzte1 Then Exit Sub
                LoLetzte2 = LoLetzte2 + 1
            Loop While Not Found Is Nothing
    End With
End Sub

Gruß Hajo
Das Forum lebt auch von den Rückmeldungen.
Bild

Betrifft: Super! Vielen Dank Hajo! - o.w.T.
von: Fritz
Geschrieben am: 27.03.2005 16:39:07

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Makro an veränderte Anforderungen anpassen"