AW: Histogramme Datenbereich
10.11.2023 10:55:35
Chrisi
Hallo,
anbei die Beispiel Datei
https://www.herber.de/bbs/user/164174.xlsm
ich möchte wenn das Makro gestartet wird, mein ganzer Code (ebenfalls beigefügt) durchläuft und erst dann das Histogramm erstellt wird und die Daten ausgewählt werden.
Option Explicit
Dim wsOutput As Worksheet
Dim sql_cmd As String
Dim sql_result As Variant
Dim metis As Object
Sub Messung()
'Deaktivieren von Bildschirm Updates während Lauf des Makros
Application.ScreenUpdating = False
'Deaktivieren von Bildschirm Alarmen während Lauf des Makros
Application.DisplayAlerts = False
'deklarieren von Variablen
Dim wsh As Worksheet
Dim ws As Worksheet
Dim DateiPfad As String
Dim LosnummerFuerDateien As String
Dim Lrow1 As Integer
Dim Current As Worksheet
Dim shtCount As Integer
Dim UpperControlLimitDicke As Double
Dim LowerControlLimitDicke As Double
Dim UpperControlLimitAuslenkung As Double
Dim LowerControlLimitAuslenkung As Double
Dim UpperControlLimitRIS As Double
Dim LowerControlLimitRIS As Double
Dim UpperControlLimitFrequenz As Double
Dim LowerControlLimitFrequenz As Double
Dim AnzahlVonMessungen As Integer
Dim StueckzahlSAP As Integer
Dim Lrow2 As Integer
Dim strSkip As String
Set metis = Ora_connect("METIS", "auskunft", "auskunft")
Application.StatusBar = "fetching data"
'Festlegen des Speicherortes
DateiPfad = Sheets("Start").Range("A11").Value
'gewünschten Losnummer übergabe
LosnummerFuerDateien = Sheets("Start").Range("A13").Value
'set to current worksheet name
Set ws = ActiveWorkbook.Sheets("Rohdaten_gesamt")
'nicht benötigte tabellen löschen
strSkip = "Start, Rohdaten_gesamt, Auswertung, Output_SAP"
For Each wsh In Worksheets
If InStr(strSkip, wsh.Name) = 0 Then
wsh.Delete
End If
Next
'Daten von vorherigen Durchlauf löschen
Worksheets("Rohdaten_gesamt").Rows(2 & ":" & Worksheets("Rohdaten_gesamt").Rows.Count).Delete
'Datei auswählen und importieren
Dim fd As FileDialog, Lrow As Long, vSelectedItem As Variant, srcWB As Workbook, desWB As Workbook
Set desWB = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = True
.InitialFileName = DateiPfad
If .Show = -1 Then
For Each vSelectedItem In .SelectedItems
'csv files nach semikolon trennen
Workbooks.OpenText Filename:=vSelectedItem _
, Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=True, _
Comma:=False, Space:=False, Other:=False, OtherChar:=";", FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7 _
, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array _
(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), _
Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array( _
27, 1), Array(28, 1)), TrailingMinusNumbers:=True
If Left(ActiveWorkbook.Name, 9) = LosnummerFuerDateien Then
Set srcWB = ActiveWorkbook
ActiveSheet.Name = ActiveWorkbook.Name
Sheets(1).Copy After:=desWB.Sheets(desWB.Sheets.Count)
srcWB.Close
Else
ActiveWorkbook.Close
GoTo Iteration
End If
Iteration:
Next
End If
End With
'Anzahl der Sheets zählen
shtCount = Sheets.Count
If shtCount = 2 Then
GoTo Iteration1
Else
For Each Current In ThisWorkbook.Worksheets
If Current.Name = "Start" Or Current.Name = "Rohdaten_gesamt" Or Current.Name = "Auswertung" Or Current.Name = "Output_SAP" Then
GoTo Iteration2
Else
Current.Activate
Range("A15").Select
LowerControlLimitDicke = Right(ActiveCell.Value, 3)
ActiveCell.Offset(1, 0).Select
UpperControlLimitDicke = Right(ActiveCell.Value, 3)
Range("A52").Select
LowerControlLimitAuslenkung = Right(ActiveCell.Value, 3)
ActiveCell.Offset(1, 0).Select
UpperControlLimitAuslenkung = Right(ActiveCell.Value, 3)
Range("A82").Select
UpperControlLimitFrequenz = Right(ActiveCell.Value, 5)
ActiveCell.Offset(1, 0).Select
LowerControlLimitFrequenz = Right(ActiveCell.Value, 5)
Lrow2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A92:AB" & Lrow2).Select
Selection.Copy
Sheets("Rohdaten_gesamt").Activate
Lrow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Cells(Lrow1 + 1, 1).Select
ActiveSheet.Paste
End If
Iteration2:
Next Current
End If
Iteration1:
sql_cmd = "SELECT a.RMENGE, a.TEXT FROM vs.KOPFLL k INNER JOIN vs.APOSLL a ON (k.LOSNR = a.LOSNR) WHERE a.TEXT = 'POLEN / MESSEN AUSLENKUNG' And k.LOSNR = '" & LosnummerFuerDateien & "'"
sql_result = sql_request(metis, sql_cmd)
Set wsOutput = ThisWorkbook.Sheets("Output_SAP")
wsOutput.UsedRange.ClearContents
Call sql2table(sql_result, ThisWorkbook.Name, wsOutput.Name, 1, 2, 1, False, True)
Worksheets("Rohdaten_gesamt").Range("A1:AB856").AutoFilter Field:=28, Criteria1:="Good"
Sheets("Auswertung").Activate
Range("B3").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[1])"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[2])"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[7])"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[8])"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(1,Rohdaten_gesamt!C[10])"
ActiveCell.Offset(-4, 1).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C)"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[1])"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[6])"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[7])"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(8,Rohdaten_gesamt!C[9])"
ActiveCell.Offset(-4, 2).Select
ActiveCell.Value = UpperControlLimitDicke
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = LowerControlLimitDicke
ActiveCell.Offset(1, -1).Select
ActiveCell.Value = UpperControlLimitAuslenkung
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = LowerControlLimitAuslenkung
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "75"
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = "139"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "3"
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "2"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = LowerControlLimitFrequenz
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = UpperControlLimitFrequenz
Sheets("Rohdaten_gesamt").Activate
Lrow2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
AnzahlVonMessungen = WorksheetFunction.Subtotal(3, Range("A2:A" & Lrow2))
Columns("A:AB").EntireColumn.AutoFit
Columns("A:AB").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
Sheets("Output_SAP").Activate
StueckzahlSAP = Range("A2").Value
Sheets("Auswertung").Activate
Range("I3").Select
ActiveCell.Value = AnzahlVonMessungen
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = StueckzahlSAP
If Range("H3").Value > Range("I3").Value Then
Range("H3:I3").Select
Selection.Interior.ColorIndex = 3
Else
Range("H3:I3").Select
Selection.Interior.ColorIndex = 4
End If
End Sub