Mit VBA einen Bereich kopieren und sortieren
- Sonstige
Sie verwenden einen veralteten Browser (%browser%) mit Sicherheitsschwachstellen und können nicht alle Funktionen dieser Webseite nutzen.
Hier erfahren Sie, wie einfach Sie Ihren Browser aktualisieren können.
Hier erfahren Sie, wie einfach Sie Ihren Browser aktualisieren können.
Es gibt 12 Antworten in diesem Thema. Der letzte Beitrag () ist von Ola.
-
-
Die letzte Zeile bekommst du mit--
If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
-- -
-
Ola schrieb:
LastRowB = Cells.Find(What:="*", After:=[B12], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Der Trick an der Routine ist, dass er von A1 aus rückwärts suchen soll und damit die letzte Zelle findet
Wenn du aber LastRowB ermitteln willst, ist die zweite Methode einfacher.
Worksheets("FMEA").Range(.Cells(12, 2), .Cells(LastRowB, 2)).Copy .Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Oder mit Direktadressierung:
Möglicherweise geht es aber noch viel einfacher:
Intersect bildet eine Schnittmenge aus allen angegebenen Ranges.--
If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
--Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „petaod“ ()
-
-
Ola schrieb:
Wäre vielleicht schneller, wenn ich die Definitionen für LastRow bei nicht alle oben, sondern direkt über den jeweiligen Codes, schreiben würde.
Wenn du Geschwindigkeit heraus holen willst, dann mach vor der Operation und wenn du mit allem fertig bist
Problem 2 und 3 warten noch auf kluge Köpfe
Ich muss gestehen, dass ich bisher noch nicht versucht habe, es zu verstehen.
Auf dem Rechner hier gibt's kein Excel und ich glaube, die beiden Probleme lassen sich nicht so einfach im Kopf lösen wie das erste.
Wenn sich keiner erbarmt, kann ich die nächsten Tage vielleicht mal reinschauen.--
If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
-- -
-
-
-
erstmal der Code fürs kopieren, sollte wesentlich schneller laufen
Visual Basic-Quellcode
- Option Explicit
- Sub FastCopy()
- Dim ws1 As Worksheet
- Dim ws2 As Worksheet
- Dim cRng As Variant
- Dim LastRow1 As Long
- Dim LastRow2 As Long
- Dim statusBarState As Boolean
- Dim calcState As XlCalculation
- Dim eventState As Boolean
- statusBarState = Application.DisplayStatusBar
- calcState = Application.Calculation
- eventsState = Application.EnableEvents
- Application.ScreenUpdating = False
- Application.DisplayStatusBar = False
- Application.Calculation = xlCalculationManual
- Application.EnableEvents = False
- 'SPALTE B
- Set ws1 = Worksheets("FMEA")
- Set ws2 = Worksheets("Pareto Analyse")
- LastRow1 = ws1.Cells(Rows.Count, 2).End(xlDown).Row
- 'Nach WS2 in Spalte B
- cRng = ws1.Range(ws1.Cells(12, 2), ws1.Cells(LastRow1, 2))
- LastRow2 = UBound(cRng)
- ws2.Range(ws2.Cells(9, 2), ws2.Cells(LastRow2, 2)) = cRng
- 'Von/Nach WS2 in Spalte F
- ws2.Range(ws2.Cells(9, 6), ws2.Cells(LastRow2, 6)) = cRng
- 'Nach WS2 in SPALTE C
- LastRow1 = ws1.Cells(Rows.Count, 3).End(xlDown).Row
- cRng = ws1.Range(ws1.Cells(12, 3), ws1.Cells(LastRow1, 3))
- LastRow2 = UBound(cRng)
- ws2.Range(ws2.Cells(9, 3), ws2.Cells(LastRow2, 3)) = cRng
- 'Von/Nach WS2 in Spalte G
- ws2.Range(ws2.Cells(9, 7), ws2.Cells(LastRow2, 7)) = cRng
- 'Nach WS2 in Spalte L
- LastRow1 = ws1.Cells(Rows.Count, 12).End(xlDown).Row
- cRng = ws1.Range(ws1.Cells(12, 12), ws1.Cells(LastRow1, 12))
- LastRow2 = UBound(cRng)
- ws2.Range(ws2.Cells(9, 4), ws2.Cells(LastRow2, 4)) = cRng
- 'Von/Nach WS2 in Spalte H
- ws2.Range(ws2.Cells(9, 8), ws2.Cells(LastRow2, 8)) = cRng
- ws2.Sort.SortFields.Add Key:=Range( _
- "H9"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
- xlSortNormal
- With ws2.Sort
- .SetRange Range(Cells(9, 6), Cells(LastRow2, 8))
- .Header = xlGuess
- .MatchCase = False
- .Orientation = xlTopToBottom
- .SortMethod = xlPinYin
- .Apply
- End With
- Application.ScreenUpdating = True
- Application.DisplayStatusBar = statusBarState
- Application.Calculation = calcState
- Application.EnableEvents = eventsState
- End Sub
Problem 3 schau ich mir noch an ^^
//Edit:
Also wenn ich bei deinem Code das hier weglasse:
Visual Basic-Quellcode
- 'Leerzeilen fŸr Gruppierungssymbole einfŸgen
- 'lngLetzteZeile = wksA.Cells(wksA.Rows.Count, 2).End(xlUp).Row
- 'For lngZeile = lngLetzteZeile To 3 Step -1
- ' Do
- ' If Val(wksA.Cells(lngZeile - 1, 2).Value) > Val(wksA.Cells(lngZeile, 2).Value) + 1 Then
- ' wksA.Rows(lngZeile).Insert
- ' wksA.Cells(lngZeile, 2).Value = wksA.Cells(lngZeile + 1, 2).Value + 1
- ' Else
- ' Exit Do
- ' End If
- ' Loop
- 'Next
Scheint es zu funktionieren.
Ich verwende allerdings Excel 2010^^
Was klappt denn nicht, wenn du das weglässt?Das ist meine Signatur und sie wird wunderbar sein!Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Mono“ ()
-
-
Ändere mal:
Visual Basic-Quellcode
- LastRow1 = ws1.Cells(Rows.Count, 2).End(xlDown).Row
- zu
- LastRow1 = ws1.Range("B65536").End(xlUp).Row
- 'Und das für alle LastRow1 (2 -> B, 3 -> C und 12 ->L)
- 'Ausserdem ändere LastRow2 wie folgt;
- If LastRow1 < 65528 Then LastRow2 = UBound(cRng) + 8
- 'hier mal das ganze für den ersten Block:
- LastRow1 = ws1.Range("B65536").End(xlUp).Row
- 'Nach WS2 in Spalte B
- cRng = ws1.Range(ws1.Cells(12, 2), ws1.Cells(LastRow1, 2))
- 'Hier
- If LastRow1 <> 65528 Then LastRow2 = UBound(cRng) + 8
- ws2.Range(ws2.Cells(9, 2), ws2.Cells(LastRow2, 2)) = cRng
- 'Von/Nach WS2 in Spalte F
- ws2.Range(ws2.Cells(9, 6), ws2.Cells(LastRow2, 6)) = cRng
Mach das genauso bei Spalte C und L.
Bei mir kam mit der anderen Variante immer eine Lastrow von 65535 raus, eventuell verlangsamt das das Ganze.
Bei Problem 3 habe ich noch etwas geschrieben im letzten PostDas ist meine Signatur und sie wird wunderbar sein! -
-
Ähnliche Themen
-
affenpower - - Sonstige Problemstellungen