Auswahl kopieren - Code Optimierung
21.11.2018 15:48:53
Felix
ich möchte Euch um Euren Rat zur Optimierung meines Codes bitten. er funktioniert, aber ich bin sicher es geht besser.
StartInfo:
Ich habe zwei Worksheets in einem File.
DanTysk SP=wks1
Proforma=wks2
In WKS1 werden Datensätze mit einem bestimmten Datum (ProformaDate) versehen und sollen basierend auf diesem nach WKS2 kopiert werden.
Einschränkung:
Es dürfen nicht mehr als 34 Datensätze kopiert werden. Das Kopieren muß dann unterbrochen werden und eine Fehlermeldung erscheinen.
Wks1 enthält ein Listobject mit 4500 Zeilen. Meine Methode alle 4500 Zeilen zu durchsuchen ist langwierig.
Meine Idee wäre:
- Autofilter mit ProformaDate setzen
- Zählen ob GesamtAnzahl >34
- wenn ja Abbruch
- Wenn nein Spalte für spalte kopieren.
Habt Ihr bessere Ideen bzw könntet mir mit dem Code auf den Weg helfen?
Vielen Dank schon mal,
Felix
Hier mein bisheriger Code:
Sub Proforma_Extract()
'define Variable
Dim Zeile As Long
Dim Zeilemax As Long
Dim ProformaDate As Long
Dim n As Long
Dim m As Long
'define shortkeys
Set wks1 = Sheets("DanTysk SP")
Set wks2 = Sheets("Proforma")
ProformaDate = wks2.Cells(10, 2)
' Cancel all active Autofilters in WKS1
With wks1
If .FilterMode Then .ShowAllData
'Delete old values in Proforma
wks2.Range("B14:j47").ClearContents
wks2.Range("L14:M47").ClearContents
'Count used lines
With wks1
'Zeilemax = .UsedRange.Rows.Count
Zeilemax = wks1.Cells(Rows.Count, 2).End(xlUp).Row
End With
'Report Start line in Proforma
n = 14
'check if requested date is available in Partlist
If Not IsEmpty(ProformaDate) Then
Set Found = wks1.Columns(39).Find(wks2.Cells(10, 2), LookIn:=xlValues, LookAt:=xlWhole)
'Set Found = wks1.Columns(39).Find(ProformaDate)
If Found Is Nothing Then
MsgBox "Date not found in Part list!", vbInformation, "Meldung"
GoTo Ende
Else
'MsgBox "Wert in Zelle " & Found.Address, vbInformation, "Meldung"
End If
End If
'Find lines with wished date
For Zeile = 8 To Zeilemax
Application.DisplayAlerts = False
If wks1.Cells(Zeile, 39).Value = ProformaDate Then
'Copy Amount
wks1.Cells(Zeile, 15).Copy
wks2.Cells(n, 2).PasteSpecial xlPasteValues
'Copy PackagingAmount
wks1.Cells(Zeile, 40).Copy
wks2.Cells(n, 3).PasteSpecial xlPasteValues
'Copy Description Commodity
wks1.Cells(Zeile, 14).Copy
wks2.Cells(n, 5).PasteSpecial xlPasteValues
'Copy Custom tarif no
wks1.Cells(Zeile, 24).Copy
wks2.Cells(n, 6).PasteSpecial xlPasteValues
'Copy Dual use
wks1.Cells(Zeile, 28).Copy
wks2.Cells(n, 7).PasteSpecial xlPasteValues
'Copy Country Code
wks1.Cells(Zeile, 26).Copy
wks2.Cells(n, 9).PasteSpecial xlPasteValues
'Copy Wheigt/item
wks1.Cells(Zeile, 34).Copy
wks2.Cells(n, 10).PasteSpecial xlPasteValues
'Copy Price-Value/item
wks1.Cells(Zeile, 18).Copy
wks2.Cells(n, 12).PasteSpecial xlPasteValues
'Copy Currency
wks1.Cells(Zeile, 17).Copy
wks2.Cells(n, 13).PasteSpecial xlPasteValues
n = n + 1
'Check if more then 34 Items have been selected
If n - 14 = 34 Then
MsgBox "You have chosen more then 34 items! Please Tag the Rest items with a _
diffrent Tag for Custom Declaration Date!", vbInformation, "Meldung"
GoTo Ende
End If
End If
Application.DisplayAlerts = True
Next Zeile
End With
'Adjust width of columns
'wks2.Columns.AutoFit
Ende:
End Sub