Mit VBA einen Bereich kopieren und sortieren

  • Sonstige

Es gibt 12 Antworten in diesem Thema. Der letzte Beitrag () ist von Ola.

    Die letzte Zeile bekommst du mit

    Visual Basic-Quellcode

    1. LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Wenn du die letzte Zeile einer bestimmten Spalte suchst:

    Visual Basic-Quellcode

    1. LastRow = Cells(Rows.Count,2).End(xlUp).Row 'Zeile der letzte gefüllte Zelle in Spalte 2
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    Ola schrieb:

    LastRowB = Cells.Find(What:="*", After:=[B12], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    So sucht er von B12 an rückwärts.
    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.

    Visual Basic-Quellcode

    1. LastRowB = Cells(Rows.Count,2).End(xlUp).Row


    Worksheets("FMEA").Range(.Cells(12, 2), .Cells(LastRowB, 2)).Copy .Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    Wenn du eine Property mit Punkt beginnst, benötigst du ein With, damit VBA weiß, auf welches Objekt sich der Ausdruck bezieht.

    Visual Basic-Quellcode

    1. Wirh Worksheets("FMEA")
    2. .Range(.Cells(12, 2), .Cells(LastRowB, 2)).Copy Worksheets("Produktarchitektur").Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    3. End With

    Oder mit Direktadressierung:

    Visual Basic-Quellcode

    1. set ws1 = Worksheets("FMEA")
    2. Set ws2 = Worksheets("Produktarchitektur")
    3. ws1.Range(ws1.Cells(12, 2), ws1.Cells(LastRowB, 2)).Copy ws2.Range("B9")


    Möglicherweise geht es aber noch viel einfacher:

    Visual Basic-Quellcode

    1. set ws1 = Worksheets("FMEA")
    2. Set ws2 = Worksheets("Produktarchitektur")
    3. Intersect(ws1.UsedRange, ws1.Range("B:C;F:F"), ws1.Range("12:60000").Copy ws2.Range("B9")
    Funktioniert allerdings nur, wenn hinter den letzten Zellen keine "blinden" Zellen versteckt sind.
    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.
    Ne. Der merkt sich das im Hauptspeicher, keine Angst.
    Wenn du Geschwindigkeit heraus holen willst, dann mach vor der Operation

    Visual Basic-Quellcode

    1. Application.ScreenUpdating = False
    und wenn du mit allem fertig bist

    Visual Basic-Quellcode

    1. Application.ScreenUpdating = True


    Problem 2 und 3 warten noch auf kluge Köpfe
    Vielleicht findet sich ja noch einer ;)

    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
    --

    Kannst du das Projekt nochmal hochladen ?

    "Du hast einen ungültigen oder nicht mehr gültigen Link aufgerufen.
    Zurück zur vorherigen Seite"


    Dann würde ich mir das Problem mal anschauen^^
    Das ist meine Signatur und sie wird wunderbar sein!

    erstmal der Code fürs kopieren, sollte wesentlich schneller laufen

    Visual Basic-Quellcode

    1. Option Explicit
    2. Sub FastCopy()
    3. Dim ws1 As Worksheet
    4. Dim ws2 As Worksheet
    5. Dim cRng As Variant
    6. Dim LastRow1 As Long
    7. Dim LastRow2 As Long
    8. Dim statusBarState As Boolean
    9. Dim calcState As XlCalculation
    10. Dim eventState As Boolean
    11. statusBarState = Application.DisplayStatusBar
    12. calcState = Application.Calculation
    13. eventsState = Application.EnableEvents
    15. Application.ScreenUpdating = False
    16. Application.DisplayStatusBar = False
    17. Application.Calculation = xlCalculationManual
    18. Application.EnableEvents = False
    20. 'SPALTE B
    21. Set ws1 = Worksheets("FMEA")
    22. Set ws2 = Worksheets("Pareto Analyse")
    24. LastRow1 = ws1.Cells(Rows.Count, 2).End(xlDown).Row
    25. 'Nach WS2 in Spalte B
    26. cRng = ws1.Range(ws1.Cells(12, 2), ws1.Cells(LastRow1, 2))
    27. LastRow2 = UBound(cRng)
    28. ws2.Range(ws2.Cells(9, 2), ws2.Cells(LastRow2, 2)) = cRng
    30. 'Von/Nach WS2 in Spalte F
    31. ws2.Range(ws2.Cells(9, 6), ws2.Cells(LastRow2, 6)) = cRng
    33. 'Nach WS2 in SPALTE C
    34. LastRow1 = ws1.Cells(Rows.Count, 3).End(xlDown).Row
    35. cRng = ws1.Range(ws1.Cells(12, 3), ws1.Cells(LastRow1, 3))
    36. LastRow2 = UBound(cRng)
    37. ws2.Range(ws2.Cells(9, 3), ws2.Cells(LastRow2, 3)) = cRng
    38. 'Von/Nach WS2 in Spalte G
    39. ws2.Range(ws2.Cells(9, 7), ws2.Cells(LastRow2, 7)) = cRng
    41. 'Nach WS2 in Spalte L
    42. LastRow1 = ws1.Cells(Rows.Count, 12).End(xlDown).Row
    43. cRng = ws1.Range(ws1.Cells(12, 12), ws1.Cells(LastRow1, 12))
    44. LastRow2 = UBound(cRng)
    45. ws2.Range(ws2.Cells(9, 4), ws2.Cells(LastRow2, 4)) = cRng
    46. 'Von/Nach WS2 in Spalte H
    47. ws2.Range(ws2.Cells(9, 8), ws2.Cells(LastRow2, 8)) = cRng
    48. ws2.Sort.SortFields.Add Key:=Range( _
    49. "H9"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    50. xlSortNormal
    51. With ws2.Sort
    52. .SetRange Range(Cells(9, 6), Cells(LastRow2, 8))
    53. .Header = xlGuess
    54. .MatchCase = False
    55. .Orientation = xlTopToBottom
    56. .SortMethod = xlPinYin
    57. .Apply
    58. End With
    59. Application.ScreenUpdating = True
    60. Application.DisplayStatusBar = statusBarState
    61. Application.Calculation = calcState
    62. Application.EnableEvents = eventsState
    63. End Sub


    Problem 3 schau ich mir noch an ^^

    //Edit:
    Also wenn ich bei deinem Code das hier weglasse:

    Visual Basic-Quellcode

    1. 'Leerzeilen fŸr Gruppierungssymbole einfŸgen
    2. 'lngLetzteZeile = wksA.Cells(wksA.Rows.Count, 2).End(xlUp).Row
    3. 'For lngZeile = lngLetzteZeile To 3 Step -1
    4. ' Do
    5. ' If Val(wksA.Cells(lngZeile - 1, 2).Value) > Val(wksA.Cells(lngZeile, 2).Value) + 1 Then
    6. ' wksA.Rows(lngZeile).Insert
    7. ' wksA.Cells(lngZeile, 2).Value = wksA.Cells(lngZeile + 1, 2).Value + 1
    8. ' Else
    9. ' Exit Do
    10. ' End If
    11. ' Loop
    12. '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

    1. LastRow1 = ws1.Cells(Rows.Count, 2).End(xlDown).Row
    2. zu
    3. LastRow1 = ws1.Range("B65536").End(xlUp).Row
    5. 'Und das für alle LastRow1 (2 -> B, 3 -> C und 12 ->L)
    6. 'Ausserdem ändere LastRow2 wie folgt;
    7. If LastRow1 < 65528 Then LastRow2 = UBound(cRng) + 8
    9. 'hier mal das ganze für den ersten Block:
    10. LastRow1 = ws1.Range("B65536").End(xlUp).Row
    11. 'Nach WS2 in Spalte B
    12. cRng = ws1.Range(ws1.Cells(12, 2), ws1.Cells(LastRow1, 2))
    13. 'Hier
    14. If LastRow1 <> 65528 Then LastRow2 = UBound(cRng) + 8
    15. ws2.Range(ws2.Cells(9, 2), ws2.Cells(LastRow2, 2)) = cRng
    17. 'Von/Nach WS2 in Spalte F
    18. 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 Post
    Das ist meine Signatur und sie wird wunderbar sein!

Facebook
Telefonspende