VBA Datenabfrage im Zeitraum für mehere Monate
18.10.2018 14:08:29
Christian
die letzten Aufgaben was ich hatte wurden durch die Forumsgemeinde sehr gut gelöst. Großen Dank hier nochmal an die letzten Helfer, Rudi, Lupo, FCS, etc....
Ich weiß auch das das nachfolgende VBA Makro "nicht gerade gut aussieht" Aber es läuft, und es nimmt mir wahnsinnig viel Arbeit ab!
Jetzt habe ich folgendes Problem. Bisher werden Daten nach einem bestimmten Monat abgefragt, was nun nicht mehr reicht. Ich müsste das ganze ändern, damit nur Daten abgefragt werden, welche entweder mit Monaten angebeben werden die durch Komma getrennt sind 8,9,10. Oder ich kann den Zeitraum über einen Kalender einschränken Von: 01.08.2018 Bis: 31.10.2018.
Kann mir hier jemand helfen?
Danke
Christian
------------------------------------------------------
Sub Sendungen_je_Agenturen()
Dim c As Range, ErgBereich As Range, _
mon As String, _
einheit As String, _
RP As String, _
laR As Long, _
check As Boolean
Dim objKst As Object
Tabelle8.Unprotect Password:=""
Tabelle9.Unprotect Password:=""
Set objKst = CreateObject("scripting.dictionary")
objKst("Kst") = "Sendungen"
'Workbooks("Abrechnungsdaten.xlsm").Worksheets("Datenlieferung_Agenturen").Range("A2:N5000"). _
ClearContents
Workbooks("Abrechnungsdaten.xlsm").Worksheets("Datenlieferung_Agenturen").Rows("2:5000"). _
Delete
Worksheets("Cube_Rohdaten").Activate
mon = InputBox(vbCr & vbCr & vbCr & "Bitte den Monat eingeben, für den die Abrechnung erzeugt _
werden soll (1 - 12)" _
& vbNewLine & vbNewLine _
& " Der Lauf kann bis zu 10 Sekunden dauern ")
If mon = "" Then check = True
If IsNumeric(mon) Then
If mon 12 Then check = True
Else
check = True
End If
If check = True Then
MsgBox "Keine oder falsche Eingabe !" & vbCr & vbCr & _
"Bitte wiederholen mit den richtigen Eingaben", vbOKOnly + vbCritical, _
"Dezenter Hinweis für " & Application.UserName & ":"
BlattschutzAn
Worksheets("Cube_Filter").Activate
Exit Sub
End If
Application.ScreenUpdating = False
laR = Cells(Rows.Count, 3).End(xlUp).Row
For Each c In Range("C2:C" & laR)
If IsDate(c.Text) Then
If Month(CDate(c.Text)) = mon And c.Offset(, 3) = "Elektronische _
Konsolidierungsproduktion" And c.Offset(, 6) = "Sendungen" And c.Offset(, 8) Like "A-*" Then
objKst(c.Offset(, 8).Value) = objKst(c.Offset(, 8).Value) + c.Offset(, 7) * 1
End If
End If
Next c
If objKst.Count = 1 Then
MsgBox "Es wurden keine Daten für den Monat " & mon & " gefunden!", vbOKOnly + _
vbInformation, _
"Dezenter Hinweis für " & Application.UserName & ":"
Worksheets("Cube_Filter").Activate
GoTo Ende
Else
With Sheets("Datenlieferung_Agenturen")
.Cells(2, 11).Resize(objKst.Count) = WorksheetFunction.Transpose(objKst.keys)
.Cells(2, 10).Resize(objKst.Count) = WorksheetFunction.Transpose(objKst.Items)
Worksheets("Datenlieferung_Agenturen").Activate
ActiveSheet.Rows(2).Delete
End With
Worksheets("Datenlieferung_Agenturen").Activate
End If
Workbooks("Abrechnungsdaten.xlsm").Worksheets("Cube_Filter").Range("A2:K4000").Clear
Application.ScreenUpdating = False
laR = Cells(Rows.Count, 3).End(xlUp).Row
For Each c In Range("C2:C" & laR)
If IsDate(c.Text) Then
If Month(CDate(c.Text)) = mon And c.Offset(, 3) = "Elektronische _
Konsolidierungsproduktion" And c.Offset(, 6) = "Sendungen" And c.Offset(, 8) Like "A-*" Then
If ErgBereich Is Nothing Then
Set ErgBereich = c.EntireRow
Else
Set ErgBereich = Union(ErgBereich, c.EntireRow)
End If
End If
End If
Next c
ErgBereich.Copy Workbooks("Abrechnungsdaten.xlsm").Worksheets("Cube_Filter"). _
Range("A2")
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set ErgBereich = Nothing
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set objKst = Nothing
'Kostenstelle Zahlenspalte aktualisieren auf Basis aktueller Kostenstellen
'Tabelle2.KST_Zahlen_anpassen
'Datenlieferung Tabelle mit Werte und Formatierungen, sowie Kostenstellen Bezeichnungen fü _
llen
Tabelle8.KostenCubeAgenturen (mon)
MsgBox ("Die Aufbereitung wurde erfolgreich durchgeführt. Die Daten wurden in die Tabelle: _
" _
& " [Cube_Filter und Datenlieferung_Agenturen]" _
& " geschrieben")
Ende:
Tabelle8.Protect Password:=""
Tabelle9.Protect Password:=""
Tabelle8.Activate
End Sub