Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1880to1884
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Suchen und kopieren
26.04.2022 10:48:00
Ramadani
Hallo zusammen
Da mir hier ziemlich gut geholfen wurde, wende ich mich gerne nochmal an die Profis hier :D
Und zwar geht es dieses mal um folgendes:
Ich habe eine Datei mit mehreren Blättern (Tabelle1, 45.01, 45.02,usw.).
In der Tabelle1 werden jeweils Daten aufgenommen bzw. festgehalten, den Code hierfür habe ich und der funktioniert soweit bestens.
Nun aber mein eigentliches Problem: In den Blättern 45.01, 45.02, usw. habe ich ab Zeile 49 eine zusätzliche Liste. Ziel ist es, dass ich über einen VBA - Befehl, welcher an einen Button "verknüpft" ist, im ersten Blatt (Tabelle1) in den Spalten E bis H nach dem Wert (45.01,45.02, usw.) suchen kann und mir dann die ganze Zeile wo der Wert enthalten ist in das entsprechende Blatt kopiert wird.
Wenn ich beim Blatt 45.01 auf den Button "Daten kopieren" drücke, dann sollen alle Zeilen in den der Wert "45.01" vorkommt ins Blatt 45.01 in der nächsten leeren Zeile eingefügt werden. Das Gleiche für die Blätter 45.02, 45.03, usw.
Wenn das möglich ist, wäre es super. Perfekt wäre es natürlich, wenn nur neue Werte kopiert werden und die alten bestehen bleiben. Wenn aber jedes mal beim Drücken auf "Daten kopieren" sämtliche Zeilen kopiert werden in denen der gesuchte Wert vorkommt, ist das nicht schlimm.
Bisher habe ich nur folgendes gefunden, aber irgendwie kriege ich den Code nicht so hin wie ich ihn gerne hätte;

Public Sub CopyRows()
Sheets("Tabelle1").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 1).Value
If ThisValue = "45.01" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("45.01").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("45.01").Select
ElseIf ThisValue = "45.02" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("45.02").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next x
End Sub
https://www.herber.de/bbs/user/152673.xlsm
Ich danke euch im Voraus ganz herzlich :)

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suchen und kopieren
26.04.2022 12:15:06
Tobi@s
Ich selbst arbeite ungern mit Buttons (arbeitstechnisch bei uns eingegrenzt) sondern meist per "Doppelklick irgendwo in Zeile 1"
Ich werde den Code jetzt nicht testen, aber wie wäre es das flexibler zu gestalten?

ThisValue = Cells(x, 1).Value
Cells(x, 1).Resize(1, 33).Copy
Sheets(ThisValue).Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Sheets1").Select
so brauchst du gar nicht prüfen wegen dem Wert. Und wenn dann Werte drin stehen (ThisValue) wo es kein Tabellenblatt gibt kann man ja mit "on Error" arbeiten.
Mit der Prüfung, ob der Wert schon erhalten ist ... das ist noch mal ein anderes Thema, aber sollte auch nicht wirklich schwer zu händeln sein. Wäre ja auch nur wieder eine Schleife und Prüfung irgendwie.
Anzeige
AW: Suchen und kopieren
27.04.2022 12:45:34
Ramadani
Hallo Tobi@s
Danke für deinen Input. Ich bin natürlich offen für alles, was es mir ermöglicht die entsprechenden Zeilen ins entsprechende Blatt zu kopieren.
Es ist lediglich wichtig, dass die Zeilen in denen der benötigte Wert enthalten ist, auch ins entsprechende Blatt kopiert werden.
Gruss
Hixi
AW: Suchen und kopieren
26.04.2022 12:19:57
Yal
Hallo Ramadani,
folgendes Code sollte passen:

Public Sub CopyRows()
Dim Abgleich As Double
Dim ZielZelle As Range
Dim R As Range ' R für Row, C für Column. Laufvariable, also Variablen für einen For meistens mono-buchstabig
Dim Z As Range ' Z für Zelle
'Referenzwert erzeugen
Abgleich = CDbl(Replace(ActiveSheet.Name, ".", ","))
'für alle Zeile der ListObject (=aktive/intelligente Tabelle)
For Each R In Sheets("Tabelle1").ListObjects("Tabelle1").DataBodyRange.Rows
'für jede Zelle diese Zeile
For Each Z In R.Cells
If Z.Value = Abgleich Then
'Zielzelle ermitteln
Set ZielZelle = ActiveSheet.Range("A99999").End(xlUp)
'Bei erster Zeile eines ListObjects gibt es ein Sonderverhalten, dass damit abgebügelt wird
If ZielZelle  "" Then Set ZielZelle = ZielZelle.Offset(1, 0)
'kopieren dorthin
R.Copy ZielZelle
'der Rest der Quell-Zeile soll ignoriert werden
Exit For
End If
Next
Next
End Sub
Du musst noch anschliessend alle Schaltfläche dieses Makro zuweisen.
VG
Yal
Anzeige
AW: Suchen und kopieren
26.04.2022 13:46:53
Ramadani
Ganz herzlichen Dank für die raschen Antworten.
Ich hab jetzt mal den folgenden Code probiert, aber leider zeigt er mir bei "Abgleich = CDbl(Replace(ActiveSheet.Name, ".", ","))" einen Fehler (Laufzeitfehler '13': Typen unverträglich)
Hab ich da etwas übersehen :)
Gruss
Hixi
AW: Suchen und kopieren
26.04.2022 14:03:58
Yal
Hallo Hixi/Ramadani,
man geht bei der Problemstellung davon aus, dass alle betrofenen Blätter einen Namen in Form Zahl-Zahl-Punkt-Zahl-Zahl haben. Wenn irgendwo etwas anderes dazwischen wäre, dann wird es zwar in Zahl-irgendwas nicht Zahl-komma-Zahl-Zahl umgewandelt (Replace) aber daraus kann keinen "richtigen" Zahl mit cDbl (Konvertiere ins Double) erzeugt werden. Also Fehler.
VG
Yal
Anzeige
AW: Suchen und kopieren
26.04.2022 17:06:14
Ramadani
Danke dir für die ausführliche Information :)
Nichtsdestotrotz steh ich grad aufm Schlauch. Müsste ich da noch was ändern, da die Blätter fast alle mit Zahlen beschriftet sind (45.01, 45.02, usw.) und nur das erste mit "Tabelle1"?
Tut mir leid für die Unannehmlichkeit und Dankeschön für die Hilfe bisher :)
Gruss
Hixi
AW: Suchen und kopieren
26.04.2022 17:23:02
Yal
Hallo Hixi,
in der Datei, die Du zur Verfügung gestellt hattest, sind die Schaltfläche in jeden diesen "45.xx"-Arbeitsblätter, spricht, wenn eine Schaltfläche aktiviert wird, dann befindet man sich im jeweiligen Arbeitsblatt (=ActiveSheet). Darauf basiert die Bearbeitung.
Wenn Du aber die Makro anders aufrufst (z.B. Alt+F8), dann solltest Du nicht gerade im Arbeitsblatt Tabelle1 sein.
Man kann auch eine Fehlerbehandlung einbauen, Es beseitigt den Fehler nicht, macht sie aber verständlicher.

Public Sub CopyRows()
Dim Abgleich As Double
Dim ZielZelle As Range
Dim R As Range ' R für Row, C für Column. Laufvariable, also Variablen für einen For meistens mono-buchstabig
Dim Z As Range ' Z für Zelle
On Error GoTo Catch
Try:
Abgleich = CDbl(Replace(ActiveSheet.Name, ".", ","))
For Each R In Sheets("Tabelle1").ListObjects("Tabelle1").DataBodyRange.Rows
For Each Z In R.Cells
If Z.Value = Abgleich Then
Set ZielZelle = ActiveSheet.Range("A99999").End(xlUp)
If ZielZelle  "" Then Set ZielZelle = ZielZelle.Offset(1, 0)
R.Copy ZielZelle
Exit For
End If
Next
Next
GoTo Finally
Catch:
MsgBox "Makro ""CopyRows"" weigert sich in " & ActiveSheet.Name, vbCritical, "Fehler"
Finally:
End Sub
VG
Yal
Anzeige
AW: Suchen und kopieren
27.04.2022 12:38:43
Ramadani
Hallo Yal
Danke dir ganz herzlich für deine Hilfe bisher. Ich hab das Gefühl wir sind auf dem richtigen Weg, jedoch will das ganze nicht so ganz funktionieren.
Das Kopieren des Codes in die entsprechende Datei ist das eine, anschliessend sollte der Code laufen sobald ich ihn einem Button zugewiesen habe im entsprechenden Blatt, sprich er sollte dann für das Blatt 45.01 sämtliche Werte welche in Tabelle1 sind und die 45.01 enthalten ins Blatt 45.01 kopieren bzw. die ganze Zeile in dem der Wert vorkommt. Für das Blatt 45.02 wäre eine kleine Anpassung nötig und dann würde es das Gleiche machen und zwar in Tabelle1 alle Werte mit 45.02 suchen und die ganze Zeile ins Blatt 45.02 kopieren, fürs Blatt 45.03 dann genau gleiche, usw.
Oder wäre es möglich einen Code zu haben bei Tabelle1, den ich dann einem Button zuweise und darüber dann die Werte ausgelesen werden und was dann 45.01 ist oder 45.02, 45.03 usw. wird in die entsprechenden Blätter kopiert.
Die Kopie sollte bei A50 jeweils eingefügt werden und dann immer fortlaufend in die nächste leere Zeile.
Nochmal ganz herzlichen Dank für deine Unterstützung bisher
Gruss
Hixi
Anzeige
AW: Suchen und kopieren
27.04.2022 18:02:48
Yal
Hallo Hixi,
einfach in einer For Each -Schleife über die Blätter gehen. Wenn nicht Tabelle1, dann Kopiererei anstossen. Dabei muss das Ziel-Worksheet übergeben werden.
Sieht dann so aus:

Public Sub CopyRows()
Dim Ws As Worksheet
For Each W In ThisWorkbook.Worksheets
If W.Name  "Tabelle1" Then Daten_übertragen Ws
Next
End Sub
Private Sub Daten_übertragen(ZielWs As Worksheet)
Dim Abgleich As Double
Dim ZielZelle As Range
Dim R As Range ' R für Row, C für Column. Laufvariable, also Variablen für einen For meistens mono-buchstabig
Dim Z As Range ' Z für Zelle
On Error GoTo Catch
Try:
Abgleich = CDbl(Replace(ZielWs.Name, ".", ","))
For Each R In Sheets("Tabelle1").ListObjects("Tabelle1").DataBodyRange.Rows
For Each Z In R.Cells
If Z.Value = Abgleich Then
Set ZielZelle = ZielWs.Range("A99999").End(xlUp)
If ZielZelle  "" Then Set ZielZelle = ZielZelle.Offset(1, 0)
R.Copy ZielZelle
Exit For
End If
Next
Next
GoTo Finally
Catch:
Debug.Print "Makro ""CopyRows"" weigert sich in " & ActiveSheet.Name, vbCritical, "Fehler"
Finally:
End Sub
VG
Yal
Anzeige
AW: Suchen und kopieren
28.04.2022 15:51:03
Ramadani
Hi Yal
Danke für deine Bemühungen, aber irgendwie will das Ganze bei mir nicht funktionieren. Ich hab den Code 1:1 übernommen und einem Button im Blatt 45.01 zugewiesen, aber es passiert nichts. Ich weiss nicht was ich bei deinem Code noch anpassen müsste, damit er funktioniert.
Ich hab da noch ein wenig herum probiert und einen Code zusammengestellt und einem Button im Blatt 45.01 zugewiesen, dieser durchsucht in Tabelle1 den Bereich A2:H9999 nach dem Wert (45.01), aber er kopiert mir leider nur die Werte rüber. Weisst du wie ich es hinbekomme den Code so anzupassen, dass die ganze Zeile kopiert wird?
Hier der Code:
Option Explicit
Public Loletzte As Long

Sub ml()
Dim Loletzte As Long
Dim RngZ As Range
For Each RngZ In Worksheets("Tabelle1").Range("A2:H9999")
Loletzte = Worksheets("45.01").Cells(Rows.Count, 1).End(xlUp).Row + 1
If RngZ Like "*45.01*" Then Worksheets("Tabelle2").Cells(Loletzte, 1) = RngZ
Next
End Sub
Gruss
Hixi
Anzeige
AW: Suchen und kopieren
28.04.2022 18:32:41
Yal
Hallo Hixi,
warum jetzt wieder einen Button in "45.01"? Ich dachte es wäre verworfen worden.
Mein Vorschlag: oben steht den blauen Knopf "Zum Archivthread". Geht dorthin und lese nochmal unsere ganze Konversation ohne Abbrechung. Finde dann, wo deinen Gedankensprünge Dich selbst aus dem Bahn geworfen haben. Kann ich leider nicht für Dich machen.
Ich bin anschliessend natürlich wieder offen für deine Frage.
VG
Yal

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige