Suchen finden bestimmt kopieren

Dim rg As Range Dim dat As Date dat = Date For Each rg In Worksheets("Data").Range("I1:I9999") With Worksheets("Daten2") Loletzte = .Cells(Rows.Count, 1).End(xlUp).Row + 1 If rg = dat Then Debug.Print "hallo" End If End With Next

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub test() Dim rg As Range Dim dat As Date Dim loletzteD&, loletzteA& dat = Date With Worksheets("Daten2") loletzteD = .Cells(Rows.Count, 1).End(xlUp).Row + 1 End With With Worksheets("Data") loletzteA = .Cells(Rows.Count, "I").End(xlUp).Row End With With Worksheets("Data") For Each rg In .Range("I1:I" & loletzteA) If rg.Value = dat Then .Print "hallo" Worksheets("Daten2").Cells(loletzteD, "A").Resize(1, 3).Value = .Cells(rg.Row, "A").Resize(1, 3).Value loletzteD = loletzteD + 1 End If Next End With End Sub

Option Explicit Sub test() Dim rg As Range Dim dat As Date Dim loletzteD&, loletzteA& Dim lfdNR As Long dat = Date With Worksheets("Daten2") loletzteD = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lfdNR = .Cells(loletzteD - 1, "A").Value End With With Worksheets("Data") loletzteA = .Cells(Rows.Count, "I").End(xlUp).Row End With With Worksheets("Data") For Each rg In .Range("I1:I" & loletzteA) If lfdNR

Option Explicit Sub test2() Dim rg As Range Dim dat As Date Dim loletzteD&, loletzteA& dat = Date With Worksheets("Daten2") loletzteD = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lfdNR = .Cells(loletzteD - 1, "A").Value End With With Worksheets("Data") loletzteA = .Cells(Rows.Count, "I").End(xlUp).Row End With With Worksheets("Data") For Each rg In .Range("I1:I" & loletzteA) If rg.Value = dat Then If IsError(Application.Match(.Cells(rg.Row, "A"), Worksheets("Data").Columns("A"), 0)) Then .Print "hallo" Worksheets("Daten2").Cells(loletzteD, "A").Resize(1, 3).Value = .Cells(rg.Row, "A").Resize(1, 3).Value loletzteD = loletzteD + 1 End If End If Next End With End Sub

Hallo Ihr zwei,
ich bedanke mich ganz Herzlich bei euch.
habe jetzt alles fertig so wie ich wollte. Ihr habt mir das Wochenende versüßt.
Für alle anderen die das eventuell gebrauchen können.


Option Explicit
Sub test2()
Dim rg As Range
Dim dat As Date
Dim loletzteD&, loletzteA&
dat = Date
With Worksheets("Daten2")
loletzteD = .Cells(Rows.Count, 1).End(xlUp).Row + 1
lfdNR = .Cells(loletzteD - 1, "A").Value
End With
With Worksheets("Data")
loletzteA = .Cells(Rows.Count, "I").End(xlUp).Row
End With
With Worksheets("Data")
For Each rg In .Range("I1:I" & loletzteA)
If rg.Value = dat Then
If IsError(Application.Match(.Cells(rg.Row, "A"), Worksheets("Data2").Columns("A"), 0)) Then
.Print "hallo"
Worksheets("Daten2").Cells(loletzteD, "A").Resize(1, 3).Value = .Cells(rg.Row, "A").Resize(1, 3).Value
loletzteD = loletzteD + 1
End If
End If
Next
End With
End Sub

Dort ist noch eine Kleinigkeit geändert. So funktioniert es sehr gut.

Ich wieder.
also ich habe nun das soweit fertig gemacht bei mir das es funktioniert.
Allerdings bin ich noch nicht ganz zufrieden mit meiner Arbeit und muss das nochmal Optimieren.
Idee ist da Lösung nicht .
Also wie am Anfang des Themas wollte ich werte kopieren in ein anderes Datenblatt und das ganze so lange wie es auch Zeilen gibt.
Nun würde ich gerne allen Mitarbeitern bei uns eine Datei geben wo sie genau so die Felder alle gleich sind wie bei mir. Alle Mitarbeiter schieben mir das ganze in einen gesammelten Ordner.
Nun möchte ich gerne das ich alle Excel Datei´n in diesem Ordner nach einander öffne und mir alle eingetragenen Daten in meine kopieren kann. Bei mir muss es aber fortlaufend nach unten weiter eingefügt werden und niemals überschrieben.
Z.b. ich habe 20 Datei´n jede Datei hat unterschiedlich viele Zeileneinträge. Ich möchte dann in meiner Datei jede Mappe durchgehen und jede zeile bei mir einfügen. Erste Mappe fertig dann 2te Mappe und dort auch alles rauskopieren und bei mir einfügen ohne das was überschrieben wird.
Ich hoffe Ihr könnt meinen gedanken folgen und versteht mein vorhaben.

Sub Daten_kopieren() Dim Pfad As String, Dateiname As String, iRow As Long Application.ScreenUpdating = False Pfad = "C:\Eigene Dateien\" Dateiname = Dir(Pfad & "*.xls") Do While Dateiname "" Workbooks.Open Filename:=Pfad & Dateiname iRow = ThisWorkbook.Sheets("Tabelle1").Range("A65536").End(xlUp).Offset(1, 0).Row If iRow

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread