Zeilen per Makro kopieren

Hallo Forum-Freunde,
ich bin neu im Forum und habe nur sehr wenig Erfahrung mit VBA.
Ich suche schon eine ganze Weile nach einer Lösung für mein Problem, bin jedoch hier im Forum oder bei Google nicht fündig geworden.
Ich habe eine Tabelle mit jeweils ca. 2000 Temperatur- und Zeitwerten in 12 Spalten (E-Q). Nun möcht ich den gesamten Spaltenbereich (E-Q) wo die Temperatur zum ersten mal den 520 °C Bereich überschreitet bis zum letzen mal, wo der Temperaturbereich von 620°C überschritten (Daten in Beispieldatei rot markiert) wird in eine neue Tabelle kopieren. Übrigens ich benutze Office 2016.
Der Spaltenbereich ist immer konstant, jedoch die Zeilenanzahl variiert bei jeder Messung.
Folgenden Code habe ich mir zusammengestellt, jedoch funktioniert er nur, wenn ich die Spalten-und Zeilennummer fest vergebe. Ich möchte aber den Zeilenbereich, den ich in Zelle E2 und E3 berechne, variabel vorgeben.

Private Sub CommandButton1_Click()
Worksheets("tabelle1").UsedRange.ClearContents
Dim firstrow As Long
Dim firstcol As Long
Dim lastrow As Long
Dim lastcol As Long
firstrow = 2
firstcol = 5
lastrow = 3
lastcol = 5
Sheets("Daten_gefiltert").Activate
'Folgende Zeile liefert die falschen Werte!
'Range(Cells(firstrow, firstcol), Cells(lastrow, lastcol)).Select
Range(Cells(419, 5), Cells(497, 16)).Select
Selection.copy
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Tabelle1").Activate
ActiveSheet.Rows("2:2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

Hier kann man sich auch die Datei holen.
https://www.herber.de/bbs/user/104580.xlsm
Ich hoffe, ich habe mich verständlich ausgedrückt
und bedanke mich im voraus
Manfred

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Manfred() Dim rng as range With sheets(1).columns("E:Q") For Tmin 520 to 550 Set rng = .find(Tmin) In not rng is nothing then exit for Next Tmin Debug.print rng.address For Tmax = 620 to 650 Set rng = .find(Tmax) If not Tmax is nothing then exit for Debug.print rng.address End with End sub

Sub Manfred() Dim rng As Range With Sheets(1).Columns("E:Q") For Tmin = 520 To 550 Set rng = .Find(Tmin) If Not Tmin Is Nothing Then Exit For Next Tmin Debug.Print rng.Address For Tmax = 620 To 650 Set rng = .Find(Tmax) If Not Tmax Is Nothing Then Exit For Debug.Print rng.Address Next Tmax End With End Sub

Sub Manfred2() ur = activesheet.usedrange.address Sx = split(ur, "$") lr = Sx(4) With sheets(1).columns("E:Q") .interior.colorindex = xlnone 'Tmin For i = 2 to lr If not iserror(application.match(530, .rows(i), -1)) then .rows(i).interior.color = vbyellow Exit for Endif Next i 'Tmax For i = lr to 2 step -1 If not iserror(application.match(620, .rows(i), -1)) then .rows(i).interior.color = vbred Exit for End if Next i End with End sub

Hallo Fennek,
sorry das ich mich nicht immer sofort auf deine Antwort melde, aber ich versuche das, was Du schreibst, auch zu verstehen und das ist bei mir leider immer mit umfangreichen Google-recherchen verbunden.
Dein letzter Code läuft, jedoch, wenn ich es richtig verstehe, sollen bei einer Übereinstimmung die Zeilen gelb bzw. rot gefärbt werden. Liege ich da richtig? Es ändert sich jedoch nichts an der Tabelle.
Vielleicht habe ich mich in meiner ersten Anfrage auch unverständlich ausgedrückt.
Ich bekomme von einem Datenlogger eine CSV-Datei mit 30000 bis 45000 Zeilen immer beginnend ab Zeile 9. Die Spalten sind immer Fest (E:Q). In Spalte E wird der Meßzeitpunkt gespeichert, in den restlichen Spalten steht der Temperaturverlauf der Aufheizung und Abkühlung. Folglich ist in jeder Spalte der von mir gesucht Bereich zweimal vorhanden, mich interessiern jedoch nur die Daten der Aufheizung, Bereich 520°C bis 620°C da ich diese für ein Diagramm brauche. Vielleicht kennst Du ja eine wesentlich einfachere Lösung.
Gruß
Manfred

Sub Manfred2() ur = ActiveSheet.UsedRange.Address Sx = Split(ur, "$") lr = Sx(4) With Sheets(1).Columns("e:q") .Interior.ColorIndex = xlNone For i = 2 To lr If Not IsError(Application.Match(520, .Rows(i), -1)) Then .Rows(i).Interior.Color = vbYellow Tmin = i Tmax = i Exit For End If Next i For i = lr To 2 Step -1 If Not IsError(Application.Match(620, .Rows(i), -1)) Then .Rows(i).Interior.Color = vbRed Tmin = i Tmax = i Exit For End If Next i .Rows(Tmin & ":" & Tmax).copy Destination:=Sheets(2).Cells(2, 1) End With End Sub

Sub Manfred2() Dim lr As Long Dim i As Long ur = ActiveSheet.UsedRange.Address sx = Split(ur, "$") lr = sx(4) 'Debug.Print lr With Sheets(1).Columns("e:q") .Interior.ColorIndex = xlNone For i = 2 To lr If Not IsError(Application.Match(520, .Rows(i), -1)) Then .Rows(i).Interior.Color = vbYellow tmin = i Exit For End If 'Debug.Print i Next i For i = lr To 2 Step -1 If Not IsError(Application.Match(620, .Rows(i), -1)) Then .Rows(i).Interior.Color = vbRed Tmax = i Exit For End If 'Debug.Print i Next i .Rows(tmin & ":" & Tmax).copy Destination:=Sheets(2).Cells(2, 1) End With End Sub

'Tmax Tmax = 0 With columns("E:Q") For i = 1 to 13 SZ = application.match(640, .columns(i), -1) If not iserror(sZ) then Tmax = iif(sZ > Tmax, sZ, Tmax) End if End with Debug.print Tmax Für das erste Auftreten der Mimdesttemperatur gibt es auch eine schnellere Variante, aber den fü _ r den Aggregat-Befehl, ab xl2010, brauche ich meinen andefen Rechner. Mfg

Private Sub CommandButton1_Click() Dim lr As Long Dim i As Long ur = ActiveSheet.UsedRange.Address sx = Split(ur, "$") lr = sx(4) 'Debug.Print lr With Sheets(1).Columns("e:p") .Interior.ColorIndex = xlNone For i = 9 To lr If Not IsError(Application.Match(520, .Rows(i), -1)) Then .Rows(i).Interior.Color = vbYellow 'tmin = i tmin = Cells(2, 5) Exit For End If Debug.Print i Next i For i = lr To 9 Step -1 If Not IsError(Application.Match(620, .Rows(i), -1)) Then .Rows(i).Interior.Color = vbRed 'tmax = i tmax = Cells(3, 5) Exit For End If Debug.Print i Next i .Rows(tmin & ":" & tmax).copy Destination:=Sheets(2).Cells(2, 1) End With End Sub

Sub Manfred4() Dim WS as worksheet Dim WBZ as workbook Set ws = activesheet Tmin = cells(2, "E") Tmax = cells(3, "E") Set wbz = workbooks.add Range(ws.cells(Tmin, "E", ws.cells(Tmax, "Q")).copy Wbz.sheets(1).range("a1").pastespecial 'Optional 'Wbz.saveas ("c:\tmp\manfred4.xlsx") 'Wbz.close 0 'Set wbz = nothing End sub

Private Sub CommandButton1_Click() Application.DisplayAlerts = False Worksheets("Daten Quarzsprung").Delete Application.DisplayAlerts = True Dim WS As Worksheet Dim NWS As Worksheet Set WS = ActiveSheet Tmin = Cells(2, "E") Tmax = Cells(3, "E") Set NWS = Worksheets.Add range(WS.Cells(Tmin, "E"), WS.Cells(Tmax, "Q")).copy NWS.Name = "Daten Quarzsprung" Sheets(1).range("e4").PasteSpecial 'Optional 'Wbz.saveas ("c:\tmp\manfred4.xlsx") 'Wbz.close 0 'Set wbz = nothing End Sub

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen per Makro kopieren

22 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread