AW: Verknüpfungsaktualisierung bei Makroausführung
15.01.2020 08:49:30
Andreas
Hallo Ihr Torsten,
hallo Stefan,
vielen Dank für die schnelle Rückantwort.
Ich würde es gerne mit Torstens Lösung testen.
Vielleicht könnt Ihr mir noch sagen wo bzw. wie ich das in den Code einfüge.
Bin mir hier nicht ganz sicher.
Hier der Code:
Public Sub Daten_holen_Aggregation()
Dim strPfad As String, strDatei As String
Dim raSpalte As Range
Dim wbQuelle As Workbook
Dim loSuchbegriff As Long
Dim Kostenstelle As Long
Dim KostenstelleStr As String
Dim boGefunden As Boolean
Dim loSumBewkum As Double
Dim SummeL As Double, SummeW As Double, SummeD As Double, SummeG As Double, SummeV As _
Double
Dim i As Long
Dim aktJahr As Long
aktJahr = Year(Now) Mod 100
'Pfad an deine Bedürfnisse anpassen
strPfad = "\\BRZ-SRV\Buchhaltung\d.s\WWB Tiefbau\Umsatztransparenz\"
strDatei = "Aggregation Baustellenbewertung und Leistungsplanung_ab 2015.xls*"
loSuchbegriff = ActiveSheet.Range("J1")
loSumBewkum = ActiveSheet.Range("I43")
Kostenstelle = CLng(Mid(loSuchbegriff, 1, 2))
'Bildschirmaktualisierung aus
Application.ScreenUpdating = False
'Datei öffnen
Set wbQuelle = Workbooks.Open(strPfad & strDatei)
With wbQuelle.Worksheets("Werte für Bewertung")
' Variabel initialisieren
SummeL = 0
SummeW = 0
SummeD = 0
SummeG = 0
SummeV = 0
boGefunden = True
For i = Kostenstelle To aktJahr
KostenstelleStr = "Summe 20" & i
'Suche nach Kostenstelle in Spalte 1
Set raSpalte = .Range("A:A").Find(what:=KostenstelleStr, LookIn:=xlValues, lookat:= _
xlWhole)
'wenn gefunden dann
If Not raSpalte Is Nothing Then
'bei Fund Variable auf Wahr setzen
boGefunden = boGefunden And True
'Leistung
SummeL = SummeL + .Cells(raSpalte.Row, 2).Value
'Werkstattkosten
SummeW = SummeW + .Cells(raSpalte.Row, 3).Value
'Dieselkosten
SummeD = SummeD + .Cells(raSpalte.Row, 4).Value
'Grätekosten
SummeG = SummeG + .Cells(raSpalte.Row, 5).Value
'Verwaltungkosten
SummeV = SummeV + .Cells(raSpalte.Row, 6).Value
Else
boGefunden = False
End If
Set raSpalte = Nothing
Next i
'Summe übertragen
ThisWorkbook.ActiveSheet.Range("D37") = (SummeW * loSumBewkum) / SummeL
ThisWorkbook.ActiveSheet.Range("D38") = (SummeD * loSumBewkum) / SummeL
ThisWorkbook.ActiveSheet.Range("D39") = (SummeG * loSumBewkum) / SummeL
ThisWorkbook.ActiveSheet.Range("D40") = (SummeV * loSumBewkum) / SummeL
End With
'Quelldatei ohne Speichern schließen
wbQuelle.Close (False)
'kein Fund - Meldung ausgeben
'If Not boGefunden Then MsgBox "Mindest eine der Kostenstellen wurde nicht gefunden."
'Variable aufräumen
Set wbQuelle = Nothing
'Bildschirmaktualisierung an
Application.ScreenUpdating = True
End Sub
Danke euch vorab.
Gruß
Andreas