Registriert seit: 12.03.2016
Version(en): Excel 2003
30.10.2019, 13:45
(Dieser Beitrag wurde zuletzt bearbeitet: 30.10.2019, 13:46 von Gast 123.)
Hallo freut mich auch, die beiden Katzen schlafen gerade auf dem Küchentisch. Zeit für Makro schreiben und fürs Forum. Der Code ist sehr einfach gehalten, und sucht in der Mitglieder Tabelle nach dem Suchwort. In dem Teil: With Worksheets("Veränderungen") suche ich zuerst die letzte Zelle zum Daten unten anhaengen. Dann könnt ihr selbst bestimmen welche Daten aus der Mitgliederliste in die Tabelle Veraenderungen übertragen werden. Zwei Beispiele sind vorgegeben, da müsst ihr aber bitte noch selbst die Buchstaben "zzz" für Ziel Spalten und "qqq" für die Quellspalten durch den richtigen Spaltenbuchstaben ersetzen. Dann sollte das Makro laufen. Was ihr jetzt aus welchen Spalten wohin kopiert ist eure Sache. Die Kopierzeilen könnt ihr beliebig erweitern. Viel Spass beim Testen .... mfg Gast 123 Code: Sub Daten_übertragen()
Dim strSuchwort As String, lz1 As Long
Dim MTG As Worksheet, mtFind As Range
On Error GoTo Fehler
strSuchwort = InputBox("Welches Suchwort?", "Suchwort eingeben")
If strSuchwort = Empty Then Exit Sub
Set MTG = Worksheets("Mitglieder")
'Sucht in Mitglieder die richtige Zelle in Spalte B
Set mtFind = MTG.Range("B:B").Find(What:=strSuchwort, After:=[b2], LookIn:=xlFormulas, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If mtFind Is Nothing Then MsgBox strSuchwort & " nicht gefunden": Exit Sub
With Worksheets("Veränderungen")
'Letzte Zeile in "Veränderungen" suchen (+1)
lz1 = .Cells(Rows.Count, 2).End(xlUp).Row + 1
'jetzt in die gefundenen Zeilen Werte übertragen
'** zzz=Ziel Spalte angeben, qqq=Quelle Spalte angeben
.Cells(lz1, "zzz").Value = MTG.Cells(mtFind.Row, "qqq").Value
.Cells(lz1, "zzz").Value = MTG.Cells(mtFind.Row, "qqq").Value
'usw. ... beliebig erweiterbar
End With
Exit Sub
Fehler: MsgBox "unerwarteter Fehler:" & vbLf & Error()
End Sub
Hallo freut mich auch, die beiden Katzen schlafen gerade auf dem Küchentisch. Zeit für Makro schreiben und fürs Forum. Der Code ist sehr einfach gehalten, und sucht in der Mitglieder Tabelle nach dem Suchwort. In dem Teil: With Worksheets("Veränderungen") suche ich zuerst die letzte Zelle zum Daten unten anhaengen. Dann könnt ihr selbst bestimmen welche Daten aus der Mitgliederliste in die Tabelle Veraenderungen übertragen werden. Zwei Beispiele sind vorgegeben, da müsst ihr aber bitte noch selbst die Buchstaben "zzz" für Ziel Spalten und "qqq" für die Quellspalten durch den richtigen Spaltenbuchstaben ersetzen. Dann sollte das Makro laufen. Was ihr jetzt aus welchen Spalten wohin kopiert ist eure Sache. Die Kopierzeilen könnt ihr beliebig erweitern. Viel Spass beim Testen .... mfg Gast 123 Code: Sub Daten_übertragen()
Dim strSuchwort As String, lz1 As Long
Dim MTG As Worksheet, mtFind As Range
On Error GoTo Fehler
strSuchwort = InputBox("Welches Suchwort?", "Suchwort eingeben")
If strSuchwort = Empty Then Exit Sub
Set MTG = Worksheets("Mitglieder")
'Sucht in Mitglieder die richtige Zelle in Spalte B
Set mtFind = MTG.Range("B:B").Find(What:=strSuchwort, After:=[b2], LookIn:=xlFormulas, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If mtFind Is Nothing Then MsgBox strSuchwort & " nicht gefunden": Exit Sub
With Worksheets("Veränderungen")
'Letzte Zeile in "Veränderungen" suchen (+1)
lz1 = .Cells(Rows.Count, 2).End(xlUp).Row + 1
'jetzt in die gefundenen Zeilen Werte übertragen
'** zzz=Ziel Spalte angeben, qqq=Quelle Spalte angeben
.Cells(lz1, "zzz").Value = MTG.Cells(mtFind.Row, "qqq").Value
.Cells(lz1, "zzz").Value = MTG.Cells(mtFind.Row, "qqq").Value
'usw. ... beliebig erweiterbar
End With
Exit Sub
Fehler: MsgBox "unerwarteter Fehler:" & vbLf & Error()
End Sub
Sorry versehentlich doppelt geklickt.
Registriert seit: 29.09.2015
Version(en): 2030,5
(30.10.2019, 11:49)mdt8ws schrieb: A Gibt es eventuell einen Code (Beispiel) für mein geplantes Vorhaben ?
MfG
mdt8ws Wo ist deine Beispieldatei mit geplantes Vorhaben ?
Registriert seit: 29.10.2019
Version(en): 365
Vielen Dank !
Werde ich heute Nachmittag noch ausprobieren. Melde mich dann wieder.
MfG
mdt8ws
Registriert seit: 29.10.2019
Version(en): 365
Hallo Gast 123,
ich bin absolut beeindruckt, genau das habe ich gesucht. Das Übertragen der Zellwerte funktioniert einwandfrei.
Ich habe jedoch noch Fragen:
1.) Das Übertragen funktioniert mit den angepassten Spalten einwandfrei. Sobald ich aber den nächsten Datensatz
übertragen habe, wird der vorher kopierte überschrieben. Wir möchten gerne, dass die Datensätze in der Tabelle "Veränderungen" untereinander fortgeschrieben werden.
Ist das eventuell möglich ?
2.) In der Tabelle "Mitglieder" sind in der Spalte K die Geburtsdaten (Format TT.MM.JJJJ) enthalten.
Wir möchten gerne im Suchfeld das Geburtsdatum eingeben (also nicht mehr in Spalte B nach Werten suchen), so dass dann nach Bestätigung dieser Eingabe
die Daten übertragen werden. Ich habe das schon entsprechend angepasst, funktioniert aber bei mir nicht.
Es gibt auch 3 doppelte Geburtstage in der Tabelle "Mitglieder", soll heißen, daß bei der Eingabe von einem Geburtsdatum dieser doppelten Daten auch
2 Datensätze (sind z. B. Zwillinge als Mitglieder) in die Tabelle "Veränderungen" übertragen werden.
3.) Und die letzte Frage die habe (ist aber nicht so wichtig):
Besteht die Möglichkeit aus der Tabelle "Mitglieder" beim Übertragen auch die Formatierung z. B. Zellrahmen (nicht die Formeln) zu übernehmen ?
Kann ich eventuell nochmal einen angepassten Code bekommen ?
Vielen Dank , ich hoffe dass ich nicht zu sehr nerve !
MfG
mdt8ws
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo anbei ein überarbeiteter Code für Suchen in Spalte K nach Geb.Datum. Zum kopieren sind jetzt pro Zelle drei Befehle nötig. Das Prinzip ist einfach zu verstehen. Wird im Suchlauf der Range Bereich veraendert, muss m Makro auch die Start Adresse mit geaendert werden: After:=[k2].Beachtet bitte das ich die LastZelle zum unten anhaengen in Spalte A suche. Da dürfen KEINE Leerzellen sein!! Beim kopieren dient der 1. Paste Special Befeh zum kopieren der Rahmen und Formate. Stehen in der Zelle Formeln wird die Formel mit kopiert. Der nachfolgende Paste Befehl mit xlPasteValues kopiert dann die Werte. Ich denke damit sind alle Wünsche abgedeckt. mfg Gast 123 Code: Sub Daten_übertragen()
Dim strSuchwort As Variant, lz1 As Long
Dim MTG As Worksheet, mtFind As Range
Dim Adr1 As String, wh As Integer
On Error GoTo Fehler
'3x Eingabe wiederholen wenn ungültiges Datum eingegeben wird
neu: strSuchwort = InputBox("Welches Suchwort?", "Suchwort eingeben")
If strSuchwort = Empty Then Exit Sub
If Not IsDate(strSuchwort) Then
MsgBox "Kein gültiges Datum"
If wh >= 2 Then Exit Sub
wh = wh + 1: GoTo neu
End If
Set MTG = Worksheets("Mitglieder")
'Sucht in Mitglieder die richtige Zelle in Spalte B
Set mtFind = MTG.Range("K:K").Find(What:=CDate(strSuchwort), After:=[K2], LookIn:=xlFormulas, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If mtFind Is Nothing Then MsgBox strSuchwort & " nicht gefunden": Exit Sub
With Worksheets("Veränderungen")
'Letzte Zeile in Spalte A suchen (+1)
lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
Adr1 = mtFind.Address 'für Do Loop notieren
'jetzt in die gefundenen Zeilen Werte übertragen
'** zzz=Ziel Spalte angeben, qqq=Quelle Spalte angeben
Do
lz1 = lz1 + 1 'LastZell +1 setzen
'alle Zellen kopieren und mit Format einfügen (xlPasteAll)
MTG.Cells(mtFind.Row, "A").Copy
Cells(lz1, "A").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "A").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "B").Copy
Cells(lz1, "B").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "B").PasteSpecial xlPasteValues 'kopiert Zell-Werte
'Kopiermodus zum Schluss ausschalten!
Application.CutCopyMode = False
Set mtFind = MTG.Range("K:K").FindNext(mtFind)
If mtFind Is Nothing Then Exit Sub
Loop Until Adr1 = mtFind.Address
End With
Exit Sub
Fehler: MsgBox "unerwarteter Fehler:" & vbLf & Error()
End Sub
Registriert seit: 29.10.2019
Version(en): 365
31.10.2019, 11:38
(Dieser Beitrag wurde zuletzt bearbeitet: 31.10.2019, 11:43 von WillWissen.
Bearbeitungsgrund: Codetags
)
Hallo Gast 123, super, total Klasse wir sind fast am Ziel. Habe jetzt noch 2 Fragen/Anmerkungen zum Code: Wenn ich den Code wie nachfolgend beigefügt ausführe, dann werden die Zellen einmal nur als Werte kopiert und dann nochmal in die nächste Zeile mit Werten und den Formaten, also doppelt. Ist das noch zu ändern ? Ist es möglich den Code noch so zu ändern, dass die Last Zelle zum unten anhängen in Spalte C gesucht wird ? Ansonsten alles andere TOP !!!! Nachfolgend der von mir geänderte Code oder habe ich da einen Denkfehler ? Vielen, vielen Dank ! MfG mdt8ws Code: Sub Daten_übertragen()
Dim strSuchwort As Variant, lz1 As Long
Dim MTG As Worksheet, mtFind As Range
Dim Adr1 As String, wh As Integer
On Error GoTo Fehler
'3x Eingabe wiederholen wenn ungültiges Datum eingegeben wird
neu: strSuchwort = InputBox("Welches Suchwort?", "Suchwort eingeben")
If strSuchwort = Empty Then Exit Sub
If Not IsDate(strSuchwort) Then
MsgBox "Kein gültiges Datum"
If wh >= 2 Then Exit Sub
wh = wh + 1: GoTo neu
End If
Set MTG = Worksheets("Mitglieder")
'Sucht in Mitglieder die richtige Zelle in Spalte K
Set mtFind = MTG.Range("K:K").Find(What:=CDate(strSuchwort), After:=[K2], LookIn:=xlFormulas, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If mtFind Is Nothing Then MsgBox strSuchwort & " nicht gefunden": Exit Sub
With Worksheets("Veränderungen")
'Letzte Zeile in Spalte A suchen (+1)
lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
Adr1 = mtFind.Address 'für Do Loop notieren
'jetzt in die gefundenen Zeilen Werte übertragen
'** zzz=Ziel Spalte angeben, qqq=Quelle Spalte angeben
.Cells(lz1, "C").Value = MTG.Cells(mtFind.Row, "A").Value
.Cells(lz1, "D").Value = MTG.Cells(mtFind.Row, "B").Value
Do
lz1 = lz1 + 1 'LastZell +1 setzen
'alle Zellen kopieren und mit Format einfügen (xlPasteAll)
MTG.Cells(mtFind.Row, "A").Copy
Cells(lz1, "C").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "C").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "B").Copy
Cells(lz1, "D").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "D").PasteSpecial xlPasteValues 'kopiert Zell-Werte
'Kopiermodus zum Schluss ausschalten!
Application.CutCopyMode = False
Set mtFind = MTG.Range("K:K").FindNext(mtFind)
If mtFind Is Nothing Then Exit Sub
Loop Until Adr1 = mtFind.Address
End With
Exit Sub
Fehler: MsgBox "unerwarteter Fehler:" & vbLf & Error()
End Sub
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo Sorry das ich mich jetzt erst melde, bin nicht staendig im Forum. Freut mich das der Code soweit klappt. Die LastZell in C suchen ist einfach. s. den Codeteil unten. Hinter Rows.Count die 1 in 3 aendern, das ist alles! Das ich doppelt kopiere hat mit den Rahmen zu tun, bei Werte kopieren fallen die Rahmen weg. Kopiert man nur xlPasteAll kopiert man auch die Formeln. Die können aber falsche Werte anzeigen, weil Excel eine automatische Zeilen/Spaltenverschiebung macht. Will man Werte mit Fomaten kopieren ist die doppelte Methode am sichersten. mfg Gast 123 Code: With Worksheets("Veränderungen")
'Letzte Zeile in Spalte A suchen (+1)
lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
Registriert seit: 29.10.2019
Version(en): 365
Hallo Gast 123,
vielen Dank für die tolle Unterstützung. Jetzt funktioniert alles perfekt !
MfG
mdt8ws
Registriert seit: 12.03.2016
Version(en): Excel 2003
Hallo
danke für die freundliche Rückmeldung, freut mich sehr ....
mfg Hast 123
Registriert seit: 29.10.2019
Version(en): 365
15.11.2019, 13:30
(Dieser Beitrag wurde zuletzt bearbeitet: 15.11.2019, 13:33 von WillWissen.
Bearbeitungsgrund: Codetags
)
Hallo Gast 123, ich habe den nachfolgenden Code angepasst und der funktioniert bei mir perfekt. Ich habe noch eine Frage dazu: Die Übernahme der Daten aus der Tabelle Mitglieder erfogt durch die Eingabe des Geburtsdatums in der Tabelle Veränderungen. Das klappt auch sehr gut. Schön wäre jetzt, wenn nach erfolgter Übernahme der Daten (sind nicht alle Zellen der kompletten Zeile aus der Tabelle Mitglieder) die komplette Zeile in der Tabelle Mitglieder gelöscht würde. Ist das eventuell doch eine Anpassung vom Code möglich ? MfG Gerhard Code: Sub Daten_übertragen()
Dim strSuchwort As Variant, lz1 As Long
Dim MTG As Worksheet, mtFind As Range
Dim Adr1 As String, wh As Integer
On Error GoTo Fehler
'3x Eingabe wiederholen wenn ungültiges Datum eingegeben wird
neu: strSuchwort = InputBox("Geburtsdatum eingeben - Format: TT.MM.JJJJ", "Suchmaske")
If strSuchwort = Empty Then Exit Sub
If Not IsDate(strSuchwort) Then
MsgBox "Kein gültiges Datum"
If wh >= 2 Then Exit Sub
wh = wh + 1: GoTo neu
End If
Set MTG = Worksheets("Mitglieder")
'Sucht in Mitglieder die richtige Zelle in Spalte K
Set mtFind = MTG.Range("K:K").Find(What:=CDate(strSuchwort), After:=[K2], LookIn:=xlFormulas, _
LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If mtFind Is Nothing Then MsgBox strSuchwort & " nicht gefunden": Exit Sub
With Worksheets("Veränderungen")
'Letzte Zeile in Spalte A suchen (+1)
lz1 = .Cells(Rows.Count, 3).End(xlUp).Row
Adr1 = mtFind.Address 'für Do Loop notieren
'jetzt in die gefundenen Zeilen Werte übertragen
'** zzz=Ziel Spalte angeben, qqq=Quelle Spalte angeben
Do
lz1 = lz1 + 1 'LastZell +1 setzen
'alle Zellen kopieren und mit Format einfügen (xlPasteAll)
MTG.Cells(mtFind.Row, "AC").Copy
Cells(lz1, "A").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "A").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "AD").Copy
Cells(lz1, "B").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "B").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "A").Copy
Cells(lz1, "C").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "C").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "B").Copy
Cells(lz1, "D").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "D").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "C").Copy
Cells(lz1, "E").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "E").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "D").Copy
Cells(lz1, "F").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "F").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "E").Copy
Cells(lz1, "G").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "G").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "E").Copy
Cells(lz1, "G").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "G").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "F").Copy
Cells(lz1, "H").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "H").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "J").Copy
Cells(lz1, "I").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "I").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "K").Copy
Cells(lz1, "J").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "J").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "O").Copy
Cells(lz1, "K").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "K").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "T").Copy
Cells(lz1, "L").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "L").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "U").Copy
Cells(lz1, "M").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "M").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "P").Copy
Cells(lz1, "N").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "N").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "O").Copy
Cells(lz1, "K").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "K").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "Q").Copy
Cells(lz1, "O").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "O").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "R").Copy
Cells(lz1, "P").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "P").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "W").Copy
Cells(lz1, "Q").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "Q").PasteSpecial xlPasteValues 'kopiert Zell-Werte
MTG.Cells(mtFind.Row, "AB").Copy
Cells(lz1, "R").PasteSpecial xlPasteAll 'kopiert Zellformate
Cells(lz1, "R").PasteSpecial xlPasteValues 'kopiert Zell-Werte
'Kopiermodus zum Schluss ausschalten!
Application.CutCopyMode = False
Set mtFind = MTG.Range("K:K").FindNext(mtFind)
If mtFind Is Nothing Then Exit Sub
Loop Until Adr1 = mtFind.Address
End With
Exit Sub
Fehler: MsgBox "unerwarteter Fehler:" & vbLf & Error()
End Sub
|
Zellen einer Zeile in andere Tabelle übernehmen mit Eingabemaske (VBA)
