AW: Löschvoränge beschleunigen
26.04.2018 10:22:50
Felix
Hallo Matthias,
hier mal das Makro wie es heute aussieht.
Vielen lieben Dank Dir nochmal, es leistet sehr gute Dienste und bringt einen großen Mehrwert.
Sub Import_For_GPS()
Dim zeile As Long
Dim letzte As Long
Dim anzjahre As Long
Dim anzeintrag As Long
Dim indziel As Long
Dim intSpalte As Integer
Dim werte()
Dim auswertung()
Dim daten
Dim quelle As Object
Dim ziel As Object
Dim i As Long
Dim start As Long
Dim jahr As Long
Dim spaltevar As Long
Dim j As Long
Dim DateiName As String
Dim x As Integer
Dim y As Integer
Dim jahrg17 As Long
Dim aktquart As Long
Dim startwert As Long
Application.ScreenUpdating = False
Set quelle = ActiveSheet
Set ziel = Worksheets("Transfer for GPS")
'number of project timeline and just consideration of rows where the total value is >0
anzjahre = 10
letzte = quelle.Cells(quelle.Rows.Count, 1).End(xlUp).Row
anzeintrag = Application.WorksheetFunction.CountIf(quelle.Range("H19:H" & letzte), ">0")
'calculation of index
ReDim auswertung(1 To (anzeintrag * 4 * anzjahre), 1 To 20)
ReDim werte(3, anzjahre * 4)
daten = quelle.Range(quelle.Cells(1, 1), quelle.Cells(letzte, 9 + 33 * anzjahre))
start = 7
jahr = quelle.Range("C1")
jahrg17 = CLng(quelle.Range("G17")) 'neu
aktquart = CLng(Int((Month(Date) - 1) / 3) + 1) 'neu
startwert = (jahrg17 - CLng(jahr)) * 4 + aktquart
For i = 1 To anzjahre * 4
werte(1, i) = start + IIf((i - 1) Mod 4 = 0, 9, 8)
start = werte(1, i)
werte(2, i) = IIf(i Mod 4 = 0, 4, i Mod 4)
werte(3, i) = jahr + Int((i - 1) / 4)
Next i
'transfer of relevant values to sheet Transfer for GPS
indziel = 1
spaltevar = 17
For zeile = 19 To letzte
'hours will be transfered in the 17th column (Q) and costs in the 16th column (P)
If InStr(1, daten(zeile, 1), "costs", vbTextCompare) > 0 Then spaltevar = 16
'just transfer quarterly values (hours or costs) if they have a cost item number, each _
quarterly value get an own row in the Transfer for GPS sheet
'then copy in each row all other project specific information like project number, project _
name ...
If daten(zeile, 8) > 0 And daten(zeile, 4) "" And daten(zeile, 8) "Total [hours]" And _
daten(zeile, 8) "Total [costs]" Then
For i = startwert To UBound(werte, 2)
If daten(zeile, werte(1, i)) > 0 Then
auswertung(indziel, 1) = daten(5, 2)
auswertung(indziel, 2) = daten(3, 2)
auswertung(indziel, 3) = daten(7, 2)
auswertung(indziel, 20) = daten(zeile, 3)
auswertung(indziel, 5) = daten(zeile, 4)
auswertung(indziel, 12) = werte(3, i)
auswertung(indziel, 13) = werte(2, i)
auswertung(indziel, 14) = "EUR"
auswertung(indziel, spaltevar) = daten(zeile, werte(1, i))
indziel = indziel + 1
End If
Next i
End If
Next zeile
'Clearing of existing values
ziel.Range("A5:T" & anzeintrag * 4 * anzjahre) = auswertung
Set quelle = Nothing
'Transfer C.ITEM number
ziel.Range("w5").AutoFill Destination:=ziel.Range("w5:w300")
ziel.Range("w5:w300").Copy
ziel.Range("f5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer SID
ziel.Range("x5").AutoFill Destination:=ziel.Range("x5:x300")
ziel.Range("x5:x300").Copy
ziel.Range("g5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer COA
ziel.Range("y5").AutoFill Destination:=ziel.Range("y5:y300")
ziel.Range("y5:y300").Copy
ziel.Range("h5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer CC
ziel.Range("z5").AutoFill Destination:=ziel.Range("z5:z300")
ziel.Range("z5:z300").Copy
ziel.Range("i5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer CC Resp.
ziel.Range("ab5").AutoFill Destination:=ziel.Range("ab5:ab300")
ziel.Range("ab5:ab300").Copy
ziel.Range("k5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer Cost item declaration
ziel.Range("aa5").AutoFill Destination:=ziel.Range("aa5:aa300")
ziel.Range("aa5:aa300").Copy
ziel.Range("j5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer CC-Loc
ziel.Range("u5").AutoFill Destination:=ziel.Range("u5:u300")
ziel.Range("u5:u300").Copy
ziel.Range("d5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer Headcount
ziel.Range("ac5").AutoFill Destination:=ziel.Range("ac5:ac300")
ziel.Range("ac5:ac300").Copy
ziel.Range("r5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Transfer CD Group
ziel.Range("ad5").AutoFill Destination:=ziel.Range("ad5:ad300")
ziel.Range("ad5:ad300").Copy
ziel.Range("s5").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'set number format
ziel.Columns("P:Q").NumberFormat = "#,##0.00"
Set ziel = Nothing
'delete all rows where are no values but a formula
intSpalte = 1
i = IIf(Len(Cells(Rows.Count, intSpalte)), Rows.Count, Cells(Rows.Count, intSpalte).End( _
xlUp).Row) + 1
j = Cells.SpecialCells(xlCellTypeLastCell).Row
If i
Viele Grüße aus Regensburg
Felix