EXCEL VBA Module aus Gries.xla
(Stand 2013-10-24)
Attribute VB_Name = "Makrosammlung_Gries"
'(c) 2005-2013, Michael Gries
'Erstellung: 2005-10-16
'Letzte Änderung SVDO: 2007-07-29
'Erstellung Hypercom: 2009-11-11
'Erstellung VeriFone: 2011-08-08
'Erstellung B.Braun: 2013-03-01
'Vorletzte Änderung: 2012-02-25
'Letzte Änderung: 2013-03-01
Public Const Last_Modified As String = "2013-03-01" '= Letzte Änderung 'Gries.xla'
Option Explicit
Public Const sCopyright As String = "(c)2005-2013, Michael Gries"
Public Const csAddinTitle As String = "Quality (Gries.xla) " & Last_Modified
Public Const csAddinComment As String = "(c)2011-2013 Michael Gries, -1642, B.Braun Melsungen"
Private Declare Function SystemBeep Lib "kernel32.dll" _
Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Sub Set_MacroShortcutKeys()
'belegt ist) diese Datei mit AddIn=false geöffnet werden, um unter
'Menü Extras/Macro/Optionen die alte Tastenbelegung zu löschen
'Tastenkombination zuordnen
Application.MacroOptions Macro:="Set_Autofilter", _
HasShortcutKey:=True, ShortcutKey:="A"
Application.MacroOptions Macro:="Format_Border_Bold", _
HasShortcutKey:=True, ShortcutKey:="B"
' Application.MacroOptions Macro:="Toggle_Comments", _
' HasShortcutKey:=True, ShortcutKey:="C"
Application.MacroOptions Macro:="Add_Charge", _
HasShortcutKey:=True, ShortcutKey:="C"
Application.MacroOptions Macro:="DauerlaufMessung", _
HasShortcutKey:=True, ShortcutKey:="E"
Application.MacroOptions Macro:="SchnelleMessung", _
HasShortcutKey:=True, ShortcutKey:="F"
Application.MacroOptions Macro:="GitternetzAnAus", _
HasShortcutKey:=True, ShortcutKey:="G"
Application.MacroOptions Macro:="Histo_Diagramm", _
HasShortcutKey:=True, ShortcutKey:="H"
Application.MacroOptions Macro:="MonthViewer", _
HasShortcutKey:=True, ShortcutKey:="K"
Application.MacroOptions Macro:="Insert_HypercomLogo", _
HasShortcutKey:=True, ShortcutKey:="L"
Application.MacroOptions Macro:="Format_Muster", _
HasShortcutKey:=True, ShortcutKey:="M"
Application.MacroOptions Macro:="Formel_RTC", _
HasShortcutKey:=True, ShortcutKey:="N"
' Application.MacroOptions Macro:="Format_Prüfwerte", _
' HasShortcutKey:=False, ShortcutKey:="P"
Application.MacroOptions Macro:="QI_p_Diagramm", _
HasShortcutKey:=True, ShortcutKey:="P"
Application.MacroOptions Macro:="PPT_Diagramm", _
HasShortcutKey:=True, ShortcutKey:="Q"
'Shortcut R used for Microsft Windows Rechner (calc)
Application.MacroOptions Macro:="Insert_Statistik", _
HasShortcutKey:=True, ShortcutKey:="S"
Application.MacroOptions Macro:="Open_Folder_Musterbau", _
HasShortcutKey:=True, ShortcutKey:="T"
Application.MacroOptions Macro:="QI_U_Diagramm", _
HasShortcutKey:=True, ShortcutKey:="U"
Application.MacroOptions Macro:="Add_Empty_Column", _
HasShortcutKey:=True, ShortcutKey:="X"
Application.MacroOptions Macro:="Convert_ASC_Dateien", _
HasShortcutKey:=True, ShortcutKey:="Y"
Application.MacroOptions Macro:="Concatenate_Sheets", _
HasShortcutKey:=True, ShortcutKey:="Z"
End Sub
Sub Standardprofil_Gries()
Application.CommandBars("Visual Basic").Visible = True
'Tastenkombination zuordnen
'ACHTUNG: Macrozuordnung hier nicht möglich, solange
'nicht alle Module geöffnet sind
End Sub
'2011-07-19
'VBA - Dezimal in Binär umrechnen
'http://www.ms-office-forum.net/forum/showthread.php?t=230000
Function dec2bin(ByVal lngZahl As Long) As String
Select Case lngZahl
Case 0
dec2bin = "0"
Case 1
dec2bin = "1"
Case Else
dec2bin = dec2bin(lngZahl \ 2) & IIf(lngZahl Mod 2, "1", "0")
End Select
End Function
'2011-01-16
Sub AutoPivotChart()
Const csPivotTableName = "Pivot"
Const csPivotChartName = "Chart"
On Error Resume Next
Sheets(csPivotTableName).Delete
Sheets(csPivotChartName).Delete
On Error GoTo 0
Dim sUsedRange As String: sUsedRange = ActiveSheet.UsedRange.Address
Dim sName As String: sName = ActiveSheet.Name & "!" & sUsedRange
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=sName).CreatePivotTable _
TableDestination:="", TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Name = csPivotTableName
Charts.Add
ActiveChart.SetSourceData Source:=Sheets(csPivotTableName).Range("A3")
ActiveChart.Location WHERE:=xlLocationAsNewSheet
ActiveSheet.Name = csPivotChartName
Dim sPivotFields1 As String
sPivotFields1 = ActiveChart.PivotLayout.PivotTable.PivotFields(1).Name
sPivotFields1 = "Count " & sPivotFields1
ActiveChart.PivotLayout.PivotTable.AddDataField ActiveChart.PivotLayout. _
PivotTable.PivotFields(1), sPivotFields1, xlCount
End Sub
Sub Show_AddInTables() 'Tastenkombination STRG+UMS+I
Attribute Show_AddInTables.VB_ProcData.VB_Invoke_Func = "I\n14"
Const csGriesHomeUser As String = "Stefanie"
Const csGriesOfficeUser As String = "mgries"
Dim strUserName As String
strUserName = GetUserLoginName()
If strUserName = csGriesHomeUser Or _
strUserName = csGriesOfficeUser _
Then
ThisWorkbook.IsAddin = False
Application.MacroOptions Macro:="Hide_AddInTables", _
HasShortcutKey:=True, ShortcutKey:="O"
End If
End Sub
Sub Hide_AddInTables() 'Tastenkombination STRG+UMS+O
Attribute Hide_AddInTables.VB_ProcData.VB_Invoke_Func = "O\n14"
ThisWorkbook.IsAddin = True
On Error Resume Next 'falls keine belibige Mappe geöffnet ist
Application.MacroOptions Macro:="Show_AddInTables", _
HasShortcutKey:=True, ShortcutKey:="I"
End Sub
'2011-01-11
Function Append_Data_To_HYC_Logfile(Data As String) As Long
'notiert einzelne Aufrufe aus hydr. Vermessung
Const csLogFile As String = "LogFile_QM.txt"
Const csLogFileADS As String = "LogFile_QM_Details.txt"
Const csLogFilePath As String = "QM\"
Const csShellCommand As String = "cmd /c @echo on && "
'
Dim sLogFileServer1 As String: sLogFileServer1 = "C:\" 'default
Dim sLogFileServer2 As String: sLogFileServer2 = "T:\" 'default
Dim sLogFilePath As String: sLogFilePath = csLogFilePath
Dim sDomain As String: sDomain = VBA.Interaction.Environ("USERDOMAIN")
'Mindestinformation
On Error Resume Next 'falls kein Workbook offen
ActiveWorkbook.BuiltinDocumentProperties("Subject").Value = ActiveWorkbook.Name
On Error GoTo 0
'
If sDomain = "HYPERCOM" Then 'Firma
'sLogFileServer1 = "\\Deheffs001\root$" 'L-Laufwerk
If Modul_WSH.CheckDriveExists("T") Then
sLogFileServer2 = "T:\" 'T-Laufwerk
sLogFilePath = csLogFilePath 'wird nicht automatisch angelegt
End If
If Modul_WSH.CheckDriveExists("L") Then
sLogFileServer1 = "L:\" 'L-Laufwerk
Else
' sLogFileServer1 = VBA.Environ("USERPROFILE")
' sLogFilePath = "\Eigene Dateien\" '!!! funktioniert hier nicht
sLogFileServer1 = "D:\" 'D-Laufwerk Laptop
sLogFilePath = ""
End If
Else 'Privat
sLogFileServer1 = "D:\"
End If
Dim sCommand1 As String: Dim sLogfile1 As String
Dim sCommand2 As String: Dim sLogfile2 As String
Dim sLogData As String: sLogData = Get_Timestamp & vbTab & Data
Dim iTaskID As Long
'
'in LogFile1 speichern
sLogfile1 = sLogFileServer1 & sLogFilePath & csLogFile
sCommand1 = csShellCommand & "ECHO " & sLogData & Get_UserData & " >> " & sLogfile1
'Debug.Print sCommand
iTaskID = Shell(sCommand1, WindowStyle:=vbHide)
'
'in LogFile2 speichern
sLogfile2 = sLogFileServer2 & sLogFilePath & csLogFile
sCommand2 = csShellCommand & "ECHO " & sLogData & Get_UserData & " >> " & sLogfile2
'Debug.Print sCommand
iTaskID = Shell(sCommand2, WindowStyle:=vbHide)
'
'und zusätzlich in Alternate Data Stream (ADS)
Dim sComputer As String: sComputer = VBA.Interaction.Environ("ComputerName")
Dim sUserProfile As String: sComputer = VBA.Interaction.Environ("UserProfile")
' Data = Get_Username & sComputer & sUserProfile
sCommand1 = csShellCommand & "ECHO " & sLogData & _
Get_UserData & Get_UserFootprint & " >> " & _
sLogfile1 & ":" & csLogFileADS
Debug.Print sCommand1, sCommand2
iTaskID = Shell(sCommand1, WindowStyle:=vbHide)
'TaskIG <> 0 = shell-Kommando wurde erfolgreich ausgeführt
Append_Data_To_HYC_Logfile = iTaskID
End Function
'2010-11-22
'2011-01-29 erweitert
'Formatiert von EasyLog USB 2 erzeugte Excel Export Dateien
'Struktur:
'1. Prüfen of als CSV-Datei (Komma separiert) schon geöffnet
'2. wenn als CSV geöffnet dann Zeilen durch Separatot in Spalten aufteilen
'3. ansonsten Öffnen-Dialog mit Öffnen als Textdatei mit Komma-Delimiter
'4. Formatierung der Daten (Autofilter, etc.)
'
Sub EasyLog_USB_ExcelExportFile()
Const csFindRange = "A1"
Const csID1 = ",High Alarm rh,Low Alarm rh,dew point"
Const csID2 = ",Serial Number"
Const csRowSerialNumber = "J"
Dim ID1: Set ID1 = Range(csFindRange).Find(csID1, LookIn:=xlValues, LookAt:=xlPart) 'xlWhole or xlPart
Dim ID2: Set ID2 = Range(csFindRange).Find(csID2, LookIn:=xlValues, LookAt:=xlPart) 'xlWhole or xlPart
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Call Split_TextSeparatedKomma
Else
Call Open_TextSeparatedKomma
End If
'Leerzeichen bei Einheiten einfügen wegen Zeilenumbruch
Cells.Replace What:="(", Replacement:=" (", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Range("1:1").WrapText = True 'Zeilenumbruch aktivieren
Range("A1").Select 'für Autofilter
Call Makrosammlung_Gries.Set_Autofilter
ActiveWindow.SplitRow = 1
ActiveWindow.FreezePanes = True
Columns("A:A").ColumnWidth = 8 'Indexspalte verkleinern
Range("C:C,F:F,I:I").NumberFormat = "0.0" 'Temperaturspalten
Dim lRowLastUsed As Long
lRowLastUsed = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
Dim sDest As String
sDest = csRowSerialNumber & "2:" & csRowSerialNumber & lRowLastUsed
Range(csRowSerialNumber & "2").AutoFill Destination:=Range(sDest)
End Sub
'2011-01-29
Sub Split_TextSeparatedKomma()
Const csDelimiter = ","
Cells(1, 1).Select
Dim lRowLastUsed As Long: lRowLastUsed = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
Dim lRow As Long
Dim sTextArrayX: Dim sText: Dim i
For lRow = 1 To lRowLastUsed
sText = Cells(lRow, 1).Value
sTextArrayX = Strings.Split(sText, csDelimiter)
For i = 0 To UBound(sTextArrayX) 'Anzahl Datensätze
Cells(lRow, i + 1).Value = sTextArrayX(i)
Next i
Next lRow
End Sub
'2011-01-29
Sub Open_TextSeparatedKomma()
Const DateiFilterTyp As String = "EasyLog - comma separated file (*.txt),*.txt"
Const DialogÖffnenTitle As String = "Öffnen: EasyLog Rohdaten"
Dim Mappen As Variant
Dim iMappen As Long
iMappen = 0
Mappen = Application.GetOpenFilename(DateiFilterTyp, FilterIndex:=0, Title:=DialogÖffnenTitle, MultiSelect:=True)
If IsArray(Mappen) Then
For iMappen = LBound(Mappen) To UBound(Mappen)
'Ggf. Meldung bei OpenText Prozedur unterdrücken, falls Format nicht erkannt wird
Application.DisplayAlerts = False
Workbooks.OpenText Filename:=Mappen(iMappen), DataType:=xlDelimited, Comma:=True
Application.DisplayAlerts = True
Next iMappen
End If
' Workbooks.OpenText Filename:= _
' "C:\Dokumente und Einstellungen\mgries\Eigene Dateien\EL010062276USB 2011-01-29 SZ.txt" _
' , Origin:=932, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
' xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
' Comma:=True, Space:=False, Other:=False, 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)), TrailingMinusNumbers:=True
End Sub
Function Append_Data_To_Logfile(Data As String) As Long
'notiert einzelne Aufrufe aus hydr. Vermessung
Const csLogFile As String = "LogFile_Vermessung.txt"
Const csLogFileADS As String = "LogFile_Vermessung_Details.txt"
Const csLogFilePath As String = "KP\Pruef_Labor_Daten\XLA_AddIn_ASCinEXCEL\"
Const csShellCommand As String = "cmd /c @echo on && "
'
Dim sLogFileServer As String
Dim sDomain As String: sDomain = VBA.Interaction.Environ("USERDOMAIN")
If sDomain = "GA" Or sDomain = "Britta" Then 'Privat
sLogFileServer = "D:\"
Else 'Firma
sLogFileServer = "\\bber021a\did82006\" '
End If
Dim sCommand As String: Dim sLogfile As String
Dim sLogData As String: sLogData = Get_Timestamp & vbTab & Data
Dim iTaskID As Long
'in logFile spreichern
sLogfile = sLogFileServer & csLogFilePath & csLogFile
sCommand = csShellCommand & "ECHO " & sLogData & Get_UserData & " >> " & sLogfile
Debug.Print sCommand
iTaskID = Shell(sCommand, WindowStyle:=vbHide)
'und zusätzlich in Alternate Data Stream (ADS)
Dim sComputer As String: sComputer = VBA.Interaction.Environ("ComputerName")
Dim sUserProfile As String: sComputer = VBA.Interaction.Environ("UserProfile")
' Data = Get_Username & sComputer & sUserProfile
sCommand = csShellCommand & "ECHO " & sLogData & _
Get_UserData & Get_UserFootprint & " >> " & _
sLogfile & ":" & csLogFileADS
Debug.Print sCommand
iTaskID = Shell(sCommand, WindowStyle:=vbHide)
'TaskIG <> 0 = shell-Kommando wurde erfolgreich ausgeführt
Append_Data_To_Logfile = iTaskID
End Function
Sub Formel_YearMonth()
'Erstellt: 2010-06-12, Michael Gries
'Zelle mit Datumswert in Form YYYY-MM umwandeln
'dabei kann es sich auch um einen Verweis auf eine andere Zelle handeln
Dim iCol As Integer: Dim iRow As Long
Dim e: Dim eV
Dim sValue As String 'als String um Leerzellen zu erkennen
For Each e In Selection
iCol = e.Column: iRow = e.row: eV = e.Value
If (IsDate(eV)) Then
If (month(eV) < 10) Then
sValue = year(eV) & "-0" & month(eV)
Else
sValue = year(eV) & "-" & month(eV)
End If
e.Value = sValue
End If
Next e
End Sub
Sub Formel_YearMonthDay()
'Erstellt: 2010-11-07, Michael Gries
'Zelle mit Datumswert in Form YYYY-MM-DD umwandeln
'dabei kann es sich auch um einen Verweis auf eine andere Zelle handeln
Dim iCol As Integer: Dim iRow As Long
Dim e: Dim eV
Dim sValue As String 'als String um Leerzellen zu erkennen
Dim sMonth As String 'Monat einstellig/zweistellig
Dim sDay As String 'Tag einstellig/zweistellig
For Each e In Selection
iCol = e.Column: iRow = e.row: eV = e.Value
If (IsDate(eV)) Then
If (Day(eV) < 10) Then
sDay = "-0" & Day(eV)
Else
sDay = "-" & Day(eV)
End If
If (month(eV) < 10) Then
sMonth = "-0" & month(eV)
Else
sMonth = "-" & month(eV)
End If
sValue = year(eV) & sMonth & sDay '& "Zusatz"
e.Value = sValue
e.NumberFormat = "yyyy-mm-dd"
End If
Next e
End Sub
Sub Formel_HGN()
'Erstellt: 2010-06-12, Michael Gries
'Zelle mit Seriennummer in HGN (8-stellig umwandeln
'dabei kann es sich auch um einen Verweis auf eine andere Zelle handeln
Dim iCol As Integer: Dim iRow As Long
Dim e: Dim eV
Dim sValue As String 'als String um Leerzellen zu erkennen
For Each e In Selection
iCol = e.Column: iRow = e.row: eV = e.Value
If (IsDate(eV)) Then GoTo Nextselection
'If (IsNumeric(eV)) Then GoTo Nextselection
sValue = eV
Dim i As Integer: i = Len(sValue)
If (i > 8) Then
sValue = Right(sValue, 8)
End If
On Error Resume Next 'falls Text keine Zahl beinhaltet
e.Value = CLng(sValue)
On Error GoTo 0
Nextselection:
Next e
End Sub
Sub Formel_RTC()
Attribute Formel_RTC.VB_ProcData.VB_Invoke_Func = "N\n14"
'Erstellt: 2010-05-31, Michael Gries
'EPP V6 Kommando n liefert Zahlenwert in Form ddmmyyhhmmss
'Prozedur dient zum umrechnen auf Initialisierungszeit
Const csTitleInputbox As String = "Berechung: EPP V6 Initialisierungszeitpunkt"
Const csParameterDefault As String = "000001123059"
Dim sDate As String: Dim sTime As String
Dim DD: Dim MMM: Dim YY: Dim hh: Dim mm: Dim ss
YY = "1900": MMM = "01": DD = "00": hh = "00": mm = "00": ss = "00"
Dim dPCtime As Date: dPCtime = Now
Dim dV6init As Date: Dim dV6time As Date
Dim sParameter As String
Dim sComment As String
sParameter = "Aktuelle Uhrzeit: " & dPCtime & vbCr & vbCr & "EPP V6 command n value ?"
Dim sInput As String: Dim sConvert As String
'ACHTUNG: folgende Umwandlung in englische Darstellung ist notwendig,
'um die automatische Gebietsschema-Konvertierung bei FormulaR1C1 zu ermöglichen
sConvert = WorksheetFunction.Substitute(sInput, ",", ".")
Dim e
Dim iCol As Integer: Dim iRow As Integer
Dim sValue As String
'als String um Leerzellen zu erkennen
Dim sFormel As String
Dim sTerm1 As String: Dim sTerm2 As String: Dim sTerm3 As String
For Each e In Selection
iCol = e.Column: iRow = e.row
sValue = Cells(iRow, iCol).Value
If sValue <> "" Then 'dann keine Leerzeile
sInput = sValue
' sTerm1 = sValue
' sTerm2 = sInput
' sTerm3 = 1
Else
sInput = InputBox(sParameter, csTitleInputbox, csParameterDefault)
' sTerm1 = sInput
' sTerm2 = 1
' sTerm3 = 1
End If
sComment = "PC-Time: " & Chr(10) & dPCtime & Chr(10) & _
"n-Command: " & Chr(10) & sInput
Select Case Len(sInput)
Case 0
sComment = "keine Eingabe"
Case 1 To 2
ss = Right(sInput, 2)
Case 3
ss = Right(sInput, 2)
mm = Mid(sInput, 1, 1)
Case 4
ss = Right(sInput, 2)
mm = Mid(sInput, 1, 2)
Case 5
ss = Right(sInput, 2)
mm = Mid(sInput, 2, 2)
hh = Mid(sInput, 1, 1)
Case 6
ss = Right(sInput, 2)
mm = Mid(sInput, 3, 2)
hh = Mid(sInput, 1, 2)
Case 12
ss = Right(sInput, 2)
mm = Mid(sInput, 9, 2)
hh = Mid(sInput, 7, 2)
DD = Mid(sInput, 5, 2)
MMM = Mid(sInput, 3, 2)
YY = "19" & Left(sInput, 2)
Case 19
sComment = "bereits Datum"
Case Else
sComment = "keine Tagangabe"
End Select
dV6time = DateSerial(YY, MMM, DD) + TimeSerial(hh, mm, ss)
'sFormel = "=" & sTerm1 & "*" & sTerm2 & "*" & sTerm3
'e.FormulaR1C1 = sFormel
dV6init = dPCtime - dV6time + 1 'plus 1 ???
e.Value = dV6init
e.NumberFormat = "dd/mm/yyyy hh:mm:ss"
With e 'für Kommentartext
.AddComment
.Comment.Visible = False 'set true for viewing permanently
.Comment.Text Text:=sComment
End With
Next e
End Sub
Function Get_Timestamp() As String
'Trennt Datum und Uhrzeit durch Tabulator für effektivere Auswertung
'z.B. durch Autofilter bei Excel. etc.
'gewählte Datumsanzeige für flexiblere Sortierung
Dim sLogDate As String: sLogDate = VBA.Format(VBA.Now, "yyyy-mm-dd")
Dim sLogTime As String: sLogTime = VBA.FormatDateTime(VBA.Now, vbLongTime)
Dim sLogHost As String: sLogHost = VBA.Environ("COMPUTERNAME") & " -"
Dim sLoginID As String: sLoginID = VBA.Environ("USERNAME") & " -"
sLogHost = Left(sLogHost, 14) 'set to fixed lenght due to tabulated text file structure
sLoginID = Left(sLoginID, 11) 'set to fixed lenght due to tabulated text file structure
Get_Timestamp = sLogDate & vbTab & sLogTime & vbTab & sLogHost & vbTab & sLoginID
End Function
Function Get_UserData() As String
Dim sLogSheetName
Dim sLogTitle As String: Dim sLogTheme As String
Dim sLogAuthor As String: Dim sLogComment As String
If Not ActiveWorkbook Is Nothing Then
With ActiveWorkbook
sLogSheetName = .Name
sLogTitle = .BuiltinDocumentProperties("TITLE")
sLogTheme = .BuiltinDocumentProperties("SUBJECT")
sLogAuthor = .BuiltinDocumentProperties("AUTHOR")
sLogComment = .BuiltinDocumentProperties("COMMENTS")
End With
End If
Get_UserData = vbTab & sLogSheetName & vbTab & sLogAuthor & _
vbTab & sLogTitle & vbTab & sLogTheme & vbTab & sLogComment
End Function
Function Get_UserFootprint() As String
Dim sLogID As String: sLogID = VBA.Environ("USERNAME")
' 'MS Word 2003 spezifische Objekte
' Dim sLogOS As String: sLogOS = System.OperatingSystem
' Dim sLogPT As String: sLogPT = System.ProcessorType
' Dim sLogHR As String: sLogHR = System.HorizontalResolution
' Dim sLogVR As String: sLogVR = System.VerticalResolution
Get_UserFootprint = vbTab & sLogID & vbTab & Modul_API_functions.ScreenResolution
' & _
' sLogPT & "/" & sLogOS & vbTab & _
' sLogHR & "x" & sLogVR
End Function
Sub View_All_Sheets()
'2007-09-11
'alle Tabellen einblenden (geht im Menü nur für jede Tabelle einzeln)
Dim e
For Each e In ActiveWorkbook.Sheets
Debug.Print e.Name
e.Visible = True
Next e
End Sub
Sub Toggle_Comments()
Attribute Toggle_Comments.VB_ProcData.VB_Invoke_Func = "C\n14"
'2006-01-19, M. Gries
'Toggle Funktion zwischen
'xlNoIndicator
'xlCommentIndicatorOnly
'xlCommentAndIndicator
Select Case Application.DisplayCommentIndicator
Case xlNoIndicator
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Case xlCommentIndicatorOnly
Application.DisplayCommentIndicator = xlCommentAndIndicator
Case xlCommentAndIndicator
Application.DisplayCommentIndicator = xlNoIndicator
End Select
End Sub
Sub Convert_WMF_Dateien()
Const sTabellenname As String = "Übersicht"
Const dWMFscale As Single = 2.5
Const DateiFilterTyp As String = "Prüfstands-Diagramme (*.wmf;*.jpg),*.wmf;*.jpg"
Const DialogÖffnenTitle As String = "Öffnen: Prüfstands-Diagramme" _
& " " & vbTab & " " & sCopyright
Dim Dateien As Variant
Dim iDateien As Long: iDateien = 0 'Initialisierung
Dim colChart As New Collection
'Application.DisplayStatusBar = False
Dateien = Application.GetOpenFilename(DateiFilterTyp, FilterIndex:=0, Title:=DialogÖffnenTitle, MultiSelect:=True)
If IsArray(Dateien) Then
Dim lngTicks: lngTicks = Modul_API_functions.GetTickCount
Application.Workbooks.Add 'Neue Excel Mappe erstellen
ActiveSheet.Name = sTabellenname
'ACHTUNG:
'Werte(Inhalte) für ActiveSheet dürfen nicht jetzt schon eingetragen
'werden, da sonst die Diagramme mit default-Diagrammtyp Inhalten versehen
'werden
For iDateien = LBound(Dateien) To UBound(Dateien)
Application.ScreenUpdating = False
'Charts.Add 'besser Sheets als Charts wegen Hyperlinkfunktionalität
Sheets.Add After:=ActiveWorkbook.Sheets(sTabellenname)
Dim sPicture: sPicture = Dateien(iDateien)
Dim sName As String: sName = GetFilenameOfPath(sPicture, False)
colChart.Add sName 'zur Sammlung hinzufügen
'Debug.Print Charts.Count; sPicture, sName
'With ActiveChart
With ActiveSheet
.Name = sName
.Pictures.Insert (sPicture)
'.SizeWithWindow = True
With .Shapes(1)
.ScaleHeight dWMFscale, msoFalse
.ScaleWidth dWMFscale, msoFalse
End With
End With
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = True
Dim rÜberschrift As Range
Set rÜberschrift = Worksheets(sTabellenname).Range("A3")
rÜberschrift.offset(2 * iDateien, 0) = ActiveSheet.Name
Worksheets(sTabellenname).Hyperlinks.Add _
Anchor:=rÜberschrift.offset(2 * iDateien, 0), _
Address:="", SubAddress:="'" & ActiveSheet.Name & "'!A1", _
TextToDisplay:=ActiveSheet.Name
Next iDateien
Worksheets(sTabellenname).Activate
With ActiveSheet
.Tab.ColorIndex = 36
With .Range("A1")
.Value = "Übersicht"
.Font.Size = 14
.Font.Bold = True
.Font.Underline = xlUnderlineStyleSingle
.RowHeight = .RowHeight * 2
End With
' Dim I
' For I = 1 To colChart.Count
' With .Range("B" & (I * 3 + 1))
' .Value = VBA.CStr(colChart.Item(I))
' .Font.Size = 12
' .Font.Bold = True
' .Font.Underline = xlUnderlineStyleSingle
' .RowHeight = .RowHeight * 2
' End With
' Next I
.Columns(1).AutoFit
End With
Debug.Print "Laufzeit: "; (GetTickCount - lngTicks); " ms"
End If
End Sub
Function GetFilenameOfPath(ByVal sPath As String, ByVal bSuffix As Boolean) As String
Const sDelimiter As String = "\"
Dim sFile As String: Dim iLength As Integer: Dim iCharacters As Integer
iLength = VBA.Len(sPath)
iCharacters = iLength - VBA.InStrRev(sPath, sDelimiter)
sFile = VBA.Right(sPath, iCharacters)
If Not bSuffix Then
sFile = VBA.Left(sFile, VBA.Len(sFile) - 4)
End If
'Update: 2006-09-08 Sheetname auf 31 Zeichen begrennzen falls Dateiname länger
If VBA.Len(sFile) > 31 Then
sFile = VBA.Left(sFile, 9) & "..." & VBA.Right(sFile, 19)
End If
GetFilenameOfPath = sFile
End Function
Sub Insert_SiemensVDOLogo()
ThisWorkbook.Worksheets("Statistik").Shapes("SiemensVDO Logo").Copy
On Error GoTo Err:
ActiveSheet.Range("A1").Activate 'immer in erste Zelle da
'Ausführung für Anwender nicht
'per Rückgängig korrigierbar
ActiveSheet.Paste
Exit Sub
Err:
If Err.Number = 91 Then 'Keine Mappe offen
Application.Workbooks.Add
Resume 0
End If
End Sub
Sub Insert_HypercomLogo()
ThisWorkbook.Charts("Diagramme").Shapes("Hypercom Logo").Copy
On Error GoTo Err:
If Selection Is Nothing Then
ActiveSheet.Range("A1").Activate 'immer in erste Zelle da
'Ausführung für Anwender nicht
End If 'per Rückgängig korrigierbar
ActiveSheet.Paste
Exit Sub
Err:
If Err.Number = 91 Then 'Keine Mappe offen
Application.Workbooks.Add
Resume 0
End If
End Sub
'2013-03-01
Sub Insert_BBraun_Logo()
ThisWorkbook.Charts("Diagramme").Shapes("BBraun_Logo").Copy
On Error GoTo Err:
If Selection Is Nothing Then
ActiveSheet.Range("A1").Activate 'immer in erste Zelle da
'Ausführung für Anwender nicht
End If 'per Rückgängig korrigierbar
ActiveSheet.Paste
Exit Sub
Err:
If Err.Number = 91 Then 'Keine Mappe offen
Application.Workbooks.Add
Resume 0
End If
End Sub
'2011-08-21
Sub Insert_VeriFoneLogo()
ThisWorkbook.Charts("Diagramme").Shapes("VeriFoneLogoMedium").Copy
On Error GoTo Err:
If Selection Is Nothing Then
ActiveSheet.Range("A1").Activate 'immer in erste Zelle da
'Ausführung für Anwender nicht
End If 'per Rückgängig korrigierbar
ActiveSheet.Paste
Exit Sub
Err:
If Err.Number = 91 Then 'Keine Mappe offen
Application.Workbooks.Add
Resume 0
End If
End Sub
Sub SpaltenGruppieren()
On Error Resume Next
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlLeft
End With
Selection.Columns.Group
End Sub
Sub ZeilenGruppieren()
On Error Resume Next
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlLeft
End With
Selection.Rows.Group
End Sub
Private Sub AddInTest()
Dim oAddIn As AddIn
Dim sAddIn As String
' sAddIn = "Asc_Quick_View.xla" 'Alternativ-Test
sAddIn = "Gries.xla"
For Each oAddIn In Application.AddIns
Debug.Print UCase(oAddIn.Name)
If UCase(oAddIn.Name) = UCase(sAddIn) Then
MsgBox UCase(sAddIn) & " ist installiert!"
Exit Sub
End If
Next
MsgBox UCase(sAddIn) & " ist nicht installiert!"
End Sub
Sub GitternetzAnAus()
Attribute GitternetzAnAus.VB_Description = "G"
Attribute GitternetzAnAus.VB_ProcData.VB_Invoke_Func = "G\n14"
On Error Resume Next
Application.ActiveWindow.DisplayGridlines = _
Not Application.ActiveWindow.DisplayGridlines
With Application.CommandBars("Worksheet Menu Bar") _
.Controls("Gries").Controls("&Gitternetzlinien Aus")
.State = Not .State
End With
End Sub
Sub Add_Dokumenteigenschaften_Applikation_Show()
'Add_Dokumenteigenschaften_Applikation True
Add_Dokumenteigenschaften_Quality True
End Sub
Sub Add_Dokumenteigenschaften_Quality(bShow As Boolean)
On Error GoTo LZF:
Dim sComments As String
sComments = "Global Quality, Qualitätsmanagement, QM"
Dim s As Worksheet
For Each s In ActiveWorkbook.Worksheets
sComments = sComments & ", " & s.Name
Next s
'Benutzerlogin ermitteln
Dim sBenutzerkennung As String
sBenutzerkennung = Modul_API_functions.GetUserLoginName
'Projektname unter VBA ändern (default: VBAProject)
ActiveWorkbook.VBProject.Name = "Applikation"
'zum Auslesen aller vorhandenen Built-In Dokument-Eigenschaften
' Dim p
' For Each p In ActiveWorkbook.BuiltinDocumentProperties
' Debug.Print p.Name
' Next
'Dokument spezifische Eigenschaften
With ActiveWorkbook 'ActiveWorkbook or for add-ins use "ThisWorkbook"
'Dokumenteigenschaften unter Register EIGENSCHAFTEN/ZUSAMMENFASSUNG
.BuiltinDocumentProperties("Title").Value = VBA.Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 0)
.BuiltinDocumentProperties("Subject").Value = ActiveSheet.Name
.BuiltinDocumentProperties("Company").Value = "VeriFone Germany GmbH"
.BuiltinDocumentProperties("Manager").Value = "Don Perkins"
.BuiltinDocumentProperties("Author").Value = "Michael Gries"
.BuiltinDocumentProperties("Application Name").Value = "Auswertung"
.BuiltinDocumentProperties("Category").Value = "Quality"
.BuiltinDocumentProperties("Comments").Value = ActiveWorkbook.FullName
.BuiltinDocumentProperties("Keywords").Value = sComments
' .BuiltinDocumentProperties("Hyperlink Base").Value = "http://www.siemensvdo.de"
'Dokumenteigenschaften unter Register EIGENSCHAFTEN/STATISTIK
.BuiltinDocumentProperties("Last Author").Value = sBenutzerkennung
.BuiltinDocumentProperties("Revision number").Value = 2
.BuiltinDocumentProperties("Total Editing Time").Value = 15 'Minuten
End With
'Dokumenteigenschaften unter Register EIGENSCHAFTEN/ANPASSEN
'ACHTUNG: geht nur einmal pro Dokument; ggf. vorher löschen
With ActiveWorkbook
On Error Resume Next
.CustomDocumentProperties("Ansprechpartner").Delete
.CustomDocumentProperties("Abteilung").Delete
.CustomDocumentProperties("Telefonnummer").Delete
'hinzufügen:
.CustomDocumentProperties.Add Name:="Ansprechpartner", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="Michael Gries"
.CustomDocumentProperties.Add Name:="Abteilung", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="QM"
.CustomDocumentProperties.Add Name:="Telefonnummer", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="-691"
End With
Debug.Print "<<< CustomDocumentProperties >>>"
Dim e
For Each e In ActiveWorkbook.CustomDocumentProperties
Debug.Print e.Name & ": " & e.Value
Next e
'Metadaten
With ActiveSheet
.CustomProperties.Add Name:="Ersteller", Value:="Michael Gries"
.CustomProperties.Add Name:="e-Mail", Value:="mgries@hypercom.com"
End With
Debug.Print "<<< CustomProperties >>>"
For Each e In ActiveSheet.CustomProperties
Debug.Print e.Name & ": " & e.Value
Next e
'Eigenschaften Dialog zwecks Überprüfung oder Änderung öffnen
If bShow Then
Application.Dialogs(xlDialogProperties).Show
End If
Exit Sub
LZF:
Debug.Print Err.Number, Err.Description
If Err.Number = 91 Then
MsgBox "Kein Arbeitsblatt ausgewählt"
End If
If Err.Number = 1004 Then
If Err.Description Like "*programmatische*" Then
'Fehler-Text:
'"Der programmatische Zugriff auf das Visual Basic-Projekt ist nicht sicher"
MsgBox "Zur Ausführung des Makros: " & vbCr & vbCr & _
"Unter Menu: Extras / Makros... / Sicherheit..." & vbCr & _
"Register: ""Vertrauenswürdige Herausgeber""" & vbCr & _
"Kontrollkästchen: ""Zugriff auf Visula Basic-Projekt vertrauen"" aktivieren", _
Title:="Makro: Dokumenteigenschaften hinzufügen"
End If
End If
End Sub
Sub Add_Dokumenteigenschaften_Applikation(bShow As Boolean)
On Error GoTo LZF:
Dim sComments As String
sComments = "Applikation, Kraftstoffpumpe"
Dim s As Worksheet
For Each s In ActiveWorkbook.Worksheets
sComments = sComments & ", " & s.Name
Next s
'Benutzerlogin ermitteln
Dim sBenutzerkennung As String
sBenutzerkennung = Modul_API_functions.GetUserLoginName
'Projektname unter VBA ändern (default: VBAProject)
ActiveWorkbook.VBProject.Name = "Applikation"
'zum Auslesen aller vorhandenen Built-In Dokument-Eigenschaften
' Dim p
' For Each p In ActiveWorkbook.BuiltinDocumentProperties
' Debug.Print p.Name
' Next
'Dokument spezifische Eigenschaften
With ActiveWorkbook 'ActiveWorkbook or for add-ins use "ThisWorkbook"
'Dokumenteigenschaften unter Register EIGENSCHAFTEN/ZUSAMMENFASSUNG
.BuiltinDocumentProperties("Title").Value = VBA.Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 0)
.BuiltinDocumentProperties("Subject").Value = ActiveSheet.Name
.BuiltinDocumentProperties("Company").Value = "Siemens VDO"
.BuiltinDocumentProperties("Manager").Value = "Bernd Wehrum"
.BuiltinDocumentProperties("Author").Value = "Michael Gries"
.BuiltinDocumentProperties("Application Name").Value = "Auswertung"
.BuiltinDocumentProperties("Category").Value = "Applikation"
.BuiltinDocumentProperties("Comments").Value = ActiveWorkbook.FullName
.BuiltinDocumentProperties("Keywords").Value = sComments
' .BuiltinDocumentProperties("Hyperlink Base").Value = "http://www.siemensvdo.de"
'Dokumenteigenschaften unter Register EIGENSCHAFTEN/STATISTIK
.BuiltinDocumentProperties("Last Author").Value = sBenutzerkennung
.BuiltinDocumentProperties("Revision number").Value = 2
.BuiltinDocumentProperties("Total Editing Time").Value = 15 'Minuten
End With
'Dokumenteigenschaften unter Register EIGENSCHAFTEN/ANPASSEN
'ACHTUNG: geht nur einmal pro Dokument; ggf. vorher löschen
With ActiveWorkbook
On Error Resume Next
.CustomDocumentProperties("Ansprechpartner").Delete
.CustomDocumentProperties("Abteilung").Delete
.CustomDocumentProperties("Telefonnummer").Delete
'hinzufügen:
.CustomDocumentProperties.Add Name:="Ansprechpartner", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:=sBenutzerkennung
.CustomDocumentProperties.Add Name:="Abteilung", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="FS RD BBE D"
.CustomDocumentProperties.Add Name:="Telefonnummer", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="-770"
End With
Debug.Print "<<< CustomDocumentProperties >>>"
Dim e
For Each e In ActiveWorkbook.CustomDocumentProperties
Debug.Print e.Name & ": " & e.Value
Next e
'Metadaten
With ActiveSheet
.CustomProperties.Add Name:="Ersteller", Value:="M. Gries"
.CustomProperties.Add Name:="e-Mail", Value:="gries.michael@siemens.com"
End With
Debug.Print "<<< CustomProperties >>>"
For Each e In ActiveSheet.CustomProperties
Debug.Print e.Name & ": " & e.Value
Next e
'Eigenschaften Dialog zwecks Überprüfung oder Änderung öffnen
If bShow Then
Application.Dialogs(xlDialogProperties).Show
End If
Exit Sub
LZF:
Debug.Print Err.Number, Err.Description
If Err.Number = 91 Then
MsgBox "Kein Arbeitsblatt ausgewählt"
End If
If Err.Number = 1004 Then
If Err.Description Like "*programmatische*" Then
'Fehler-Text:
'"Der programmatische Zugriff auf das Visual Basic-Projekt ist nicht sicher"
MsgBox "Zur Ausführung des Makros: " & vbCr & vbCr & _
"Unter Menu: Extras / Makros... / Sicherheit..." & vbCr & _
"Register: ""Vertrauenswürdige Herausgeber""" & vbCr & _
"Kontrollkästchen: ""Zugriff auf Visula Basic-Projekt vertrauen"" aktivieren", _
Title:="Makro: Dokumenteigenschaften hinzufügen"
End If
End If
End Sub
'2007-07-29: aus irgendeinem VBA Forum
Sub Sort_Ply()
Dim Tabellenblattanzahl As Integer
Dim Erste_Schleife As Integer, Zweite_Schleife As Integer
Tabellenblattanzahl = ActiveWorkbook.Worksheets.Count
For Erste_Schleife = 1 To Tabellenblattanzahl
For Zweite_Schleife = Erste_Schleife To Tabellenblattanzahl
If Worksheets(Zweite_Schleife).Name < Worksheets(Erste_Schleife).Name Then
Worksheets(Zweite_Schleife).Move Before:=Worksheets(Erste_Schleife)
End If
Next Zweite_Schleife
Next Erste_Schleife
End Sub
Sub getUserStatus()
Dim users
Dim row
users = ActiveWorkbook.UserStatus
With Workbooks.Add.Sheets(1)
For row = 1 To UBound(users, 1)
.Cells(row, 1) = users(row, 1)
.Cells(row, 2) = users(row, 2)
Select Case users(row, 3)
Case 1
.Cells(row, 3).Value = "Exclusive"
Case 2
.Cells(row, 3).Value = "Shared"
End Select
Next
End With
End Sub
Sub SaveAsMultiUserEditing()
If Not ActiveWorkbook.MultiUserEditing Then
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.FullName, _
accessMode:=xlShared
ActiveWorkbook.AutoUpdateFrequency = 5
End If
Debug.Print ActiveWorkbook.AutoUpdateFrequency
End Sub
Sub ShowConfictHistory()
If ActiveWorkbook.MultiUserEditing Then
ActiveWorkbook.ShowConflictHistory = True
End If
End Sub
Sub Windows_Rechner()
Attribute Windows_Rechner.VB_ProcData.VB_Invoke_Func = "R\n14"
Dim lTaskID
lTaskID = Shell("C:\WINDOWS\system32\CALC.EXE", 1)
'lTaskID = Shell("net send Michael Test")
Debug.Print lTaskID
On Error Resume Next
'Tastenkombination zuordnen
Application.MacroOptions Macro:="Windows_Rechner", _
HasShortcutKey:=True, ShortcutKey:="R"
End Sub
'Hilfsprozedur zum ermitteln des Colorindex Wertes
Private Sub Farbtabelle()
Dim bfarbe As Byte
Application.Workbooks.Add 'in neuer Mappe anzeigen
For bfarbe = 2 To 57
If bfarbe < 30 Then
Cells(bfarbe, 1) = bfarbe - 1
Cells(bfarbe, 2).Interior.ColorIndex = bfarbe - 1
Cells(bfarbe, 3).Font.ColorIndex = bfarbe - 1
Cells(bfarbe, 3) = bfarbe - 1
Else
Cells(bfarbe - 28, 5) = bfarbe - 1
Cells(bfarbe - 28, 6).Interior.ColorIndex = bfarbe - 1
Cells(bfarbe - 28, 7).Font.ColorIndex = bfarbe - 1
Cells(bfarbe - 28, 7) = bfarbe - 1
End If
Next bfarbe
End Sub
Sub SetColor_Siemens_Petrol()
'Erstellung: 2006-04-26
'Const iIndexBlaugrün As Integer = 14 'default Farbwert 14 ist 'Blaugrün'
Const iIndexAquamarin As Integer = 42 'default Farbwert 42 ist 'Aquamarin'
Dim iIndexPetrol As Integer: iIndexPetrol = iIndexAquamarin
'Petrol: Pantone 321; CMYK 100, 0, 40, 0; RGB 0, 164, 187
ActiveWorkbook.Colors(iIndexPetrol) = RGB(0, 164, 187)
Range("A2").Interior.ColorIndex = iIndexPetrol
End Sub
Sub SetColor_VDO_blue()
'Erstellung: 2006-04-26
Const iIndexDunkelblau As Integer = 11 'default Farbwert 11 ist 'Dunkelblau'
Dim iIndexBlue As Integer: iIndexBlue = iIndexDunkelblau
'Blue: Pantone 287; CMYK 100, 69, 0, 11; RGB 35, 77, 150
ActiveWorkbook.Colors(iIndexBlue) = RGB(35, 77, 150)
Range("B2").Interior.ColorIndex = iIndexBlue
End Sub
Sub SetColor_Thales_blue()
'Erstellung: 2008
Const iIndexDunkelblau As Integer = 11 'default Farbwert 11 ist 'Dunkelblau'
Dim iIndexBlue As Integer: iIndexBlue = iIndexDunkelblau
'Blue: Pantone 287; CMYK 100, 69, 0, 11; RGB 35, 77, 150
ActiveWorkbook.Colors(iIndexBlue) = RGB(35, 77, 150)
Range("B2").Interior.ColorIndex = iIndexBlue
End Sub
'2009-11-28
Sub SetColor_Hypercom_blue()
'Entsprechend Hypercom Corporate Indentity Guide Version 1.1'
'siehe auch Auszug Coporate Colors im Chart Diagramme
Const iIndexBlaugrün As Integer = 14 'default Farbwert 14 ist 'Blaugrün'
Dim iIndexBlue As Integer: iIndexBlue = iIndexBlaugrün
'Blue: PMS 654; CMYK 100,73,10,48; RGB 0,44,95; HTML 00C25F
ActiveWorkbook.Colors(iIndexBlue) = RGB(0, 44, 95)
Dim e
For Each e In Selection
e.Interior.ColorIndex = iIndexBlue
Next e
End Sub
'2009-11-28
Sub SetColor_Hypercom_Grey()
'Entsprechend Hypercom Corporate Indentity Guide Version 1.1'
'siehe auch Auszug Coporate Colors im Chart Diagramme
Const iIndexDunkelblau As Integer = 11 'default Farbwert 11 ist 'Dunkelblau'
Dim iIndexGrey As Integer: iIndexGrey = iIndexDunkelblau
'Grey: PMS Cool Grey 8; CMYK 23,17,13,41; RGB 139,141,142; HTML 8B8D8E
ActiveWorkbook.Colors(iIndexGrey) = RGB(139, 141, 142)
Dim e
For Each e In Selection
e.Interior.ColorIndex = iIndexGrey
Next e
End Sub
'Hilfsprozedur zum Auslesen aller vorhandenen Built-In Dokument-Eigenschaften
Private Sub BuiltIn_Properties()
Dim p
For Each p In ActiveWorkbook.BuiltinDocumentProperties
Debug.Print p.Name
Next
End Sub
Private Sub Test_SendKeys()
Dim AnwRechner, i
AnwRechner = Shell("CALC.EXE", 1) ' Rechner starten.
AppActivate AnwRechner ' Rechner aktivieren.
For i = 1 To 10 ' Zählschleife beginnen.
SendKeys i & "{+}", True ' Tastenanschläge senden, um die
SystemBeep 20000, 100 'nicht hörbar als Pause
Next i ' Werte von I zu addieren.
SendKeys "=", True ' Gesamtsumme abrufen.
'SendKeys "%{F4}", True ' Rechner mit ALT+F4 beenden.
End Sub
Sub Test_Timer()
'Dim VBATimer As New Klasse_Zeitgeber 'Name des Klassenmoduls
'
'Set VBATimer.VBA_Timer = 1
End Sub
Public Sub Add_To_Statistics()
Dim iCounter As Integer
With Application.FileSearch
.NewSearch
.LookIn = "C:\Temp\Statistik"
.SearchSubFolders = True
.Filename = "Statistik*.xls"
.MatchTextExactly = False
'.FileType = msoFileTypeAllFiles
.Execute
For iCounter = 1 To .FoundFiles.Count
Cells(iCounter + 1, 1).Value = Dir(.FoundFiles(iCounter))
Next iCounter
End With
End Sub
Sub DauerlaufMessung()
Attribute DauerlaufMessung.VB_Description = "E"
Attribute DauerlaufMessung.VB_ProcData.VB_Invoke_Func = "E\n14"
Const csHomeUser As String = "Michael"
Const csFilename As String = "SchnelleMessung.xls"
Const csHomeServer As String = "C:\Dokumente und Einstellungen\Michael\"
Const csHomePath As String = "Eigene Dateien\"
Const csOfficeServer As String = "\\bber021a\did82006\"
Const csOfficePath As String = "KP\Pruef_Labor_Daten\XLA_AddIn_ASCinEXCEL\"
Dim sServer As String: Dim sPath As String: Dim sFile As String
Dim strUserName As String
strUserName = GetUserLoginName()
If strUserName = csHomeUser Then
sServer = csHomeServer: sPath = csHomePath
Else
sServer = csOfficeServer: sPath = csOfficePath
End If
Application.Run sServer & sPath & "SchnelleMessung.xls!Convert_Diadem_File_DL"
End Sub
Sub SchnelleMessung()
Attribute SchnelleMessung.VB_Description = "F"
Attribute SchnelleMessung.VB_ProcData.VB_Invoke_Func = "F\n14"
Const csHomeUser As String = "Michael"
Const csFilename As String = "SchnelleMessung.xls"
Const csHomeServer As String = "C:\Dokumente und Einstellungen\Michael\"
Const csHomePath As String = "Eigene Dateien\"
Const csOfficeServer As String = "\\bber021a\did82006\"
Const csOfficePath As String = "KP\Pruef_Labor_Daten\XLA_AddIn_ASCinEXCEL\"
Dim sServer As String: Dim sPath As String: Dim sFile As String
Dim strUserName As String
strUserName = GetUserLoginName()
If strUserName = csHomeUser Then
sServer = csHomeServer: sPath = csHomePath: sFile = csFilename
Else
sServer = csOfficeServer: sPath = csOfficePath: sFile = csFilename
End If
Application.Run sServer & sPath & csFilename & "!Convert_ASC_File_SM"
' If AddIns("Schnellemessung").Installed = True Then
' Application.Run "SchnelleMessung.xla!Convert_ASC_File_SM"
' Else
' AddIns.Add Filename:=sServer & sPath & sFile 'AddIn Öffnen"
' Application.Run "SchnelleMessung.xla!Convert_ASC_File_SM"
' End If
End Sub
'hier nur als Info; folgende Prozedur muss in die jeweilige Tabelle kopiert werden
Private Sub Worksheet_SelectionChange _
(ByVal TargetRow As Range)
Application.EnableEvents = False
Rows(TargetRow.row).Select
TargetRow.Activate
Application.EnableEvents = True
End Sub
Sub AddEventZeilenweiseMarkieren()
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Set VBCodeMod = ThisWorkbook.VBProject. _
VBComponents("Vorlage_S").CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub Worksheet_SelectionChange(ByVal TargetRow As Range)" & VBA.Chr(13) & _
"Application.EnableEvents = False" & VBA.Chr(13) & _
"Rows(TargetRow.row).Select" & VBA.Chr(13) & _
"TargetRow.Activate" & VBA.Chr(13) & _
"Application.EnableEvents = True" & VBA.Chr(13) & _
"End Sub"
End With
End Sub
Sub AddEventZeilenweiseMarkierenExtern()
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Dim sActSheet As String
Dim sActBook As String
On Error Resume Next 'falls keine Mappe offen
Debug.Print ActiveWindow.Name
Debug.Print ActiveWindow.Panes.Count
Debug.Print ActiveWorkbook.Name
sActBook = ActiveWorkbook.Name
Application.Workbooks(sActBook).Activate
Debug.Print ActiveWindow.ActiveSheet.Name
Debug.Print ActiveSheet.Name
Debug.Print ActiveSheet.CodeName
sActSheet = ActiveSheet.CodeName
'nachfolgende IF-Routine als Workaround, fall ActiveSheet nicht erkannt
If sActSheet = "" Then
ActiveWindow.DisplayWorkbookTabs = True 'sicherstellen:
'Registerblatt sollte für Inputbox sichtbar sein
sActSheet = InputBox("Tabellennamen (s.u.) angeben", "Excel: Makro(Gries) Zeilen-Cursor setzen")
ActiveWorkbook.Worksheets(sActSheet).Activate
sActSheet = ActiveSheet.CodeName
End If
Set VBCodeMod = ActiveWorkbook.VBProject. _
VBComponents(sActSheet).CodeModule
'Debug.Print Application.VBE.CodePanes(1).CodeModule.Lines(1, 4)
Debug.Print VBCodeMod.Lines(1, 4)
'If Not VBCodeMod.Find("AddEventZeilenweiseMarkierenExtern", 12, 1, 12, 1) Then
'If VBCodeMod.CountOfLines < 3 Then
On Error GoTo NoEventDetected
LineNum = VBCodeMod.ProcBodyLine("Worksheet_SelectionChange", vbext_pk_Proc)
On Error GoTo 0
If LineNum <> 0 Then GoTo EventAlreadyExits
NoEventDetected:
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub Worksheet_SelectionChange(ByVal TargetRow As Range)" & VBA.Chr(13) & _
" 'AddEventZeilenweiseMarkierenExtern auto generated by AddIn Gries.xla; (c)2006 M. Gries" & VBA.Chr(13) & _
" Application.EnableEvents = False" & VBA.Chr(13) & _
" Rows(TargetRow.row).Select" & VBA.Chr(13) & _
" TargetRow.Activate" & VBA.Chr(13) & _
" Application.EnableEvents = True" & VBA.Chr(13) & _
"End Sub"
End With
'End If
EventAlreadyExits:
'ActiveWorkbook.Sheets(sActSheet).Activate
End Sub
Sub RemoveEventZeilenweiseMarkierenExtern()
Const lNoOfCodeLines As Long = 7
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Dim sActSheet As String
sActSheet = ActiveSheet.CodeName
If sActSheet = "" Then GoTo NoEventDetected
Set VBCodeMod = ActiveWorkbook.VBProject. _
VBComponents(sActSheet).CodeModule
Debug.Print VBCodeMod.Lines(1, 7)
On Error GoTo NoEventDetected
LineNum = VBCodeMod.ProcBodyLine("Worksheet_SelectionChange", vbext_pk_Proc)
VBCodeMod.DeleteLines LineNum, lNoOfCodeLines
NoEventDetected:
End Sub
'2011-01-29 Zusammenfassung für Hypercom, PM, Peter Florack
Sub CognosReports_Add_MarkingUniquelessSerialNumbers()
Call CognosReports_MarkDoubleSerialNumbers
Call CognosReports_MultipleSerialNumbers
End Sub
'2011-03-05 Zusammenfassung für Hypercom, S&R, Falk Stolle
Sub CognosReports_Add_MarkingUniquelessRepairOrders()
Call CognosReports_MarkDoubleRepairOrders
Call CognosReports_MultipleRepairOrders
End Sub
'2011-03-05
Sub CognosReports_MarkDoubleRepairOrders()
'2010-12-25 Sortiert Repair Order und markiert doppelte in separater Spalte
Const csCriteria = "Repair Order"
Const csColumnNew = "ROx"
Dim lRow As Long: Dim iColumn As Integer
Dim lRowLastUsed As Long
'Rows(1).Select
Dim c: Set c = Selection.Find(csCriteria, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
'Debug.Print c.Address
lRow = c.row: iColumn = c.Column
lRowLastUsed = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
'Sortierung zuerst
c.CurrentRegion.Select
Selection.Sort Key1:=Cells(lRow, iColumn), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Spalten kopieren
Columns(iColumn).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Columns(iColumn + 1).EntireColumn.Select
Selection.ClearContents
Cells(lRow, iColumn + 1).Select
Selection.Value = csColumnNew
Selection.Interior.ColorIndex = 36 'hellgelb
Dim sSN1 As String: Dim sSN2 As String
Dim sSNmark As String: Dim sSNmarkLen As Integer: Dim iSNcount As Integer
Dim l As Long
For l = lRow + 1 To lRowLastUsed
sSN1 = Cells(l, iColumn)
sSN2 = Cells(l + 1, iColumn)
sSNmark = Cells(l, iColumn + 1)
If sSN1 = sSN2 Then
If sSNmark = "" Then
Cells(l, iColumn + 1) = "1x"
Cells(l + 1, iColumn + 1) = "2x"
Else
sSNmarkLen = VBA.Strings.Len(sSNmark)
sSNmark = Left(sSNmark, sSNmarkLen - 1)
iSNcount = VBA.CInt(sSNmark)
Cells(l, iColumn + 1) = iSNcount & "x"
Cells(l + 1, iColumn + 1) = iSNcount + 1 & "x"
End If
End If
Next l
With Columns(iColumn + 1)
.AutoFit
'.ColumnWidth = 40
.HorizontalAlignment = xlCenter
End With
End If
End Sub
'2011-03-05
Sub CognosReports_MultipleRepairOrders()
'ähnlich 2011-01-16 erweitert CognosReports_MarkDoubleSerialNumbers
Const csCriteria = "ROx"
Const csColumnNew = "RO Rx"
Dim lRow As Long: Dim iColumn As Integer
Dim lRowLastUsed As Long
Dim c: Set c = Selection.Find(csCriteria, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
'Debug.Print c.Address
lRow = c.row: iColumn = c.Column
lRowLastUsed = ActiveSheet.Cells(Rows.Count, iColumn).End(xlUp).row
'Sortierung zuerst
' c.CurrentRegion.Select
' Selection.Sort Key1:=Cells(lRow, iColumn), Order1:=xlAscending, _
' Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
' Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Spalten kopieren
Columns(iColumn).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Columns(iColumn + 1).EntireColumn.Select
Selection.ClearContents
Cells(lRow, iColumn + 1).Select
Selection.Value = csColumnNew
Selection.Interior.ColorIndex = 36 'hellgelb
Dim sRO1 As String: Dim sRO2 As String
Dim sRO2Len As Integer: Dim iRO2count As Integer
Dim l As Long
For l = lRow + 2 To lRowLastUsed
sRO1 = Cells(l - 1, iColumn)
sRO2 = Cells(l, iColumn)
If Not sRO1 = sRO2 Then
sRO2Len = VBA.Strings.Len(sRO2)
sRO2 = Left(sRO2, sRO2Len - 1)
iRO2count = VBA.CInt(sRO2)
Dim r As Long
For r = 0 To iRO2count - 1
Cells(l - r, iColumn + 1) = "R" & iRO2count
Next r
End If
' Select Case sSN2
' Case ""
' 'nothing - since after 2x,3x, ...
' Case "1x"
' 'nothing - since after 2x,3x, ...
' Case "2x"
' Cells(l + 1, iColumn + 1) = "R2"
' Cells(l + 0, iColumn + 1) = "R2"
' Case "3x"
' Cells(l + 1, iColumn + 1) = "R3"
' Cells(l + 0, iColumn + 1) = "R3"
' Cells(l - 1, iColumn + 1) = "R3"
' Case "4x"
' Cells(l + 1, iColumn + 1) = "R4"
' Cells(l + 0, iColumn + 1) = "R4"
' Cells(l - 1, iColumn + 1) = "R4"
' Cells(l - 2, iColumn + 1) = "R4"
' Case "5x"
' Cells(l + 1, iColumn + 1) = "R5"
' Cells(l + 0, iColumn + 1) = "R5"
' Cells(l - 1, iColumn + 1) = "R5"
' Cells(l - 2, iColumn + 1) = "R5"
' Cells(l - 3, iColumn + 1) = "R5"
' Case Else
' Cells(l, iColumn + 1) = "unknown"
' End Select
Next l
With Columns(iColumn + 1)
.AutoFit
.HorizontalAlignment = xlCenter
End With
End If
End Sub
'2010-12-25
Sub CognosReports_MarkDoubleSerialNumbers()
'2010-12-25 Sortiert S/N und markiert dopplete in separater Spalte
Const csCriteria = "Serial"
Const csColumnNew = "S/Nx"
Dim lRow As Long: Dim iColumn As Integer
Dim lRowLastUsed As Long
Dim c: Set c = Selection.Find(csCriteria, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
'Debug.Print c.Address
lRow = c.row: iColumn = c.Column
lRowLastUsed = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
'Sortierung zuerst
c.CurrentRegion.Select
Selection.Sort Key1:=Cells(lRow, iColumn), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Spalten kopieren
Columns(iColumn).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Columns(iColumn + 1).EntireColumn.Select
Selection.ClearContents
Cells(lRow, iColumn + 1).Select
Selection.Value = csColumnNew
Selection.Interior.ColorIndex = 36 'hellgelb
Dim sSN1 As String: Dim sSN2 As String
Dim sSNmark As String
Dim l As Long
For l = lRow + 1 To lRowLastUsed
sSN1 = Cells(l, iColumn)
sSN2 = Cells(l + 1, iColumn)
sSNmark = Cells(l, iColumn + 1)
If sSN1 = sSN2 Then
Select Case sSNmark
Case ""
Cells(l, iColumn + 1) = "1x"
Cells(l + 1, iColumn + 1) = "2x"
Case "2x"
Cells(l, iColumn + 1) = "2x"
Cells(l + 1, iColumn + 1) = "3x"
Case "3x"
Cells(l, iColumn + 1) = "3x"
Cells(l + 1, iColumn + 1) = "4x"
Case "4x"
Cells(l, iColumn + 1) = "4x"
Cells(l + 1, iColumn + 1) = "5x"
Case "5x"
Cells(l, iColumn + 1) = "5x"
Cells(l + 1, iColumn + 1) = "6x"
Case Else
Cells(l, iColumn + 1) = "unknown"
End Select
Else
Select Case sSNmark
Case ""
Cells(l, iColumn + 1) = "1x"
Cells(l + 1, iColumn + 1) = ""
Case "2x"
Cells(l, iColumn + 1) = "2x"
Cells(l + 1, iColumn + 1) = ""
Case "3x"
Cells(l, iColumn + 1) = "3x"
Cells(l + 1, iColumn + 1) = ""
Case "4x"
Cells(l, iColumn + 1) = "4x"
Cells(l + 1, iColumn + 1) = ""
Case "5x"
Cells(l, iColumn + 1) = "5x"
Cells(l + 1, iColumn + 1) = ""
Case Else
Cells(l, iColumn + 1) = "else unknown"
End Select
End If
Next l
With Columns(iColumn + 1)
.AutoFit
'.ColumnWidth = 40
.HorizontalAlignment = xlCenter
End With
End If
End Sub
'2011-01-16
Sub CognosReports_MultipleSerialNumbers()
'2011-01-16 erweitert CognosReports_MarkDoubleSerialNumbers
Const csCriteria = "S/Nx"
Const csColumnNew = "S/N Mx"
Dim lRow As Long: Dim iColumn As Integer
Dim lRowLastUsed As Long
Dim c: Set c = Selection.Find(csCriteria, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
'Debug.Print c.Address
lRow = c.row: iColumn = c.Column
lRowLastUsed = ActiveSheet.Cells(Rows.Count, iColumn).End(xlUp).row
'Sortierung zuerst
' c.CurrentRegion.Select
' Selection.Sort Key1:=Cells(lRow, iColumn), Order1:=xlAscending, _
' Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
' Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Spalten kopieren
Columns(iColumn).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Columns(iColumn + 1).EntireColumn.Select
Selection.ClearContents
Cells(lRow, iColumn + 1).Select
Selection.Value = csColumnNew
Selection.Interior.ColorIndex = 36 'hellgelb
Dim sSN1 As String: Dim sSN2 As String
Dim sSNmark As String
Dim l As Long
For l = lRow + 1 To lRowLastUsed
sSN1 = Cells(l, iColumn)
sSN2 = Cells(l + 1, iColumn)
'sSNmark = Cells(l, iColumn)
If Not sSN1 = sSN2 Then
Select Case sSN2
Case ""
'nothing - since after 2x,3x, ...
Case "1x"
'nothing - since after 2x,3x, ...
Case "2x"
Cells(l + 1, iColumn + 1) = "M2"
Cells(l + 0, iColumn + 1) = "M2"
Case "3x"
Cells(l + 1, iColumn + 1) = "M3"
Cells(l + 0, iColumn + 1) = "M3"
Cells(l - 1, iColumn + 1) = "M3"
Case "4x"
Cells(l + 1, iColumn + 1) = "M4"
Cells(l + 0, iColumn + 1) = "M4"
Cells(l - 1, iColumn + 1) = "M4"
Cells(l - 2, iColumn + 1) = "M4"
Case "5x"
Cells(l + 1, iColumn + 1) = "M5"
Cells(l + 0, iColumn + 1) = "M5"
Cells(l - 1, iColumn + 1) = "M5"
Cells(l - 2, iColumn + 1) = "M5"
Cells(l - 3, iColumn + 1) = "M5"
Case Else
Cells(l, iColumn + 1) = "unknown"
End Select
Else
Select Case sSNmark
Case Else
'Cells(l, iColumn + 1) = "else unknown"
End Select
End If
Next l
With Columns(iColumn + 1)
.AutoFit
.HorizontalAlignment = xlCenter
End With
End If
End Sub
Sub Set_Autofilter()
'2010-06-12 (original version see Set_Autofilter_Musterbau)
On Error GoTo LZF1004
With ActiveSheet
.AutoFilterMode = False 'Autofilter zurücksetzen
Dim iColor As Integer: iColor = Selection.Interior.ColorIndex
Dim lRow As Long
lRow = Selection.row
Selection.Rows.AutoFit
With .Rows(lRow)
.RowHeight = .RowHeight + 12
.VerticalAlignment = xlTop
'.AutoFilter 'liefert an dieser Stelle manchmal mehr Spalten
Dim iLastCol: iLastCol = .CurrentRegion.Columns.Count
End With
.Range(Cells(lRow, 1), Cells(lRow, iLastCol)).AutoFilter
If (iColor = xlNone) Then
.Range(Cells(lRow, 1), Cells(lRow, iLastCol)).Interior.ColorIndex = 15 'hellgrau
.Range(Cells(lRow, 1), Cells(lRow, iLastCol)).Font.Bold = True
End If
'Fenster fixieren
With ActiveWindow
.SplitRow = lRow
.FreezePanes = True
End With
End With
GoTo Final
LZF1004:
'Laufzeitfehler 1004
'z.B. wenn leeres Blatt oder leere Zeile
Debug.Print "ERROR: ", Err.Number, Err.Description
MsgBox ("Gries.xla Laufzeitfehler")
Final:
End Sub
Sub Format_Status()
'Erstellt: 2006-09-09, M. Gries
'verwendet Menü Daten/Gültigkeitsregeln/Einstellungen-Liste
Const csTitle As String = "Status"
Const csListe As String = "grün,gelb,rot"
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, _
Operator:=xlBetween, Formula1:=csListe
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = csTitle
.ErrorTitle = csTitle
.InputMessage = csListe
.ErrorMessage = "nur " & csListe & " möglich"
.ShowInput = True
.ShowError = True
End With
'bedingte Formatierung anwenden
Const csCond1Text As String = "grün"
Const csCond2Text As String = "gelb"
Const csCond3Text As String = "rot"
Const ciCond1BackColor As Integer = 4 'green
Const ciCond2BackColor As Integer = 6 'yellow
Const ciCond3BackColor As Integer = 3 'red
Const ciCond1FondColor As Integer = 1 'black for green
Const ciCond2FondColor As Integer = 1 'black for yellow
Const ciCond3FondColor As Integer = 2 'white for red
With Selection
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""" & csCond1Text & """"
'Formula1:="=""grün"""
.FormatConditions(1).Interior.ColorIndex = ciCond1BackColor
With .FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = ciCond1FondColor
End With
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""" & csCond2Text & """"
'Formula1:="=""gelb"""
.FormatConditions(2).Interior.ColorIndex = ciCond2BackColor
With .FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = ciCond2FondColor
End With
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""" & csCond3Text & """"
'Formula1:="=""rot"""
.FormatConditions(3).Interior.ColorIndex = ciCond3BackColor
With .FormatConditions(3).Font
.Bold = True
.Italic = False
.ColorIndex = ciCond3FondColor
End With
End With
End Sub
Sub Format_Testresult()
'Erstellt: 2010-07-22, Michael Gries
'verwendet Menü Daten/Gültigkeitsregeln/Einstellungen-Liste
Const csTitle As String = "Testresult"
Const csListe As String = "PASS,NOT_TESTED,FAIL"
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, _
Operator:=xlBetween, Formula1:=csListe
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = csTitle
.ErrorTitle = csTitle
.InputMessage = csListe
.ErrorMessage = "nur " & csListe & " möglich"
.ShowInput = True
.ShowError = True
End With
'bedingte Formatierung anwenden
Const csCond1Text As String = "PASS"
Const csCond2Text As String = "NOT_TESTED"
Const csCond3Text As String = "FAIL"
Const ciCond1BackColor As Integer = 4 'green
Const ciCond2BackColor As Integer = 6 'yellow
Const ciCond3BackColor As Integer = 3 'red
Const ciCond1FondColor As Integer = 1 'black for green
Const ciCond2FondColor As Integer = 1 'black for yellow
Const ciCond3FondColor As Integer = 2 'white for red
With Selection
.HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""" & csCond1Text & """"
'Formula1:="=""grün"""
.FormatConditions(1).Interior.ColorIndex = ciCond1BackColor
With .FormatConditions(1).Font
.Bold = True
.Italic = False
.ColorIndex = ciCond1FondColor
End With
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""" & csCond2Text & """"
'Formula1:="=""gelb"""
.FormatConditions(2).Interior.ColorIndex = ciCond2BackColor
With .FormatConditions(2).Font
.Bold = True
.Italic = False
.ColorIndex = ciCond2FondColor
End With
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""" & csCond3Text & """"
'Formula1:="=""rot"""
.FormatConditions(3).Interior.ColorIndex = ciCond3BackColor
With .FormatConditions(3).Font
.Bold = True
.Italic = False
.ColorIndex = ciCond3FondColor
End With
End With
End Sub
Sub Format_Mitarbeiter()
'Erstellt: 2006-09-09, M. Gries
'Erstellt: 2009-11-27, Michael Gries, Hypercom
'Letzte Änderung; 2010-07-01
'verwendet Menü Daten/Gültigkeitsregeln/Einstellungen-Liste
Const csTitle As String = "Bearbeiter"
'Const csListe As String = "Wehrum,Constantin,Gries,Meiser,Rademacher,Staab"
Const csListeLN As String = "Gries,Müller,Poroffscheck,Raschke,Tonko"
Const csListe As String = "Michael Gries,Bernd Poroffscheck,Marco Müller,Anne-Katrin Raschke"
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, _
Operator:=xlBetween, Formula1:=csListe, Formula2:="Gries"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = csTitle
.ErrorTitle = csTitle
.InputMessage = csListe
.ErrorMessage = "nur " & csListe & " möglich"
.ShowInput = False '=false wegen schlechten Zeilenumbruch
.ShowError = False '=false für andere "Bearbeiter"
End With
End Sub
'2010-08-01
Sub Add_Shape()
Const xPixel As Integer = 100
Const yPixel As Integer = 100
Const xSize As Integer = 120
Const ySize As Integer = 80
ActiveSheet.Shapes.AddShape(msoShapeOval, xPixel, yPixel, xSize, ySize).Select
With Selection.ShapeRange.Fill
.Visible = msoFalse
.Solid
.Transparency = 1# 'entspricht 100%
End With
With Selection.ShapeRange.Line
.Weight = 4#
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 10
.BackColor.RGB = RGB(255, 255, 255)
End With
'Auswahl als Formen Standard festlegen
Selection.ShapeRange.SetShapesDefaultProperties
End Sub
Sub Add_CustomLists()
'Erstellt: 2006-09-09, M. Gries
'fügt neue Listen hinzu unter Menü Extras/Optionen/Benutzerdefinierte Listen
'Letzte Änderung; 2010-05-10
'Application.AddCustomList _
' ListArray:=Array("Wehrum", "Constantin", "Gries", "Meiser", "Rademacher", "Staab")
'Application.AddCustomList _
' ListArray:=Array("Lenz", "Lotz", "Schmidt", "Warnke", "Zöll")
Application.AddCustomList _
ListArray:=Array("Walter Tonko", "Michael Gries", "Bernd Poroffscheck", "Marco Müller", "Anne-Katrin Raschke")
End Sub
Public Function Wochen(iWochen As Integer) As Date
'2006-09-23
'fügt Anzahl Wochen zum aktuellen Datum hinzu
Debug.Print Selection.Address
Debug.Print Selection.Value
Wochen = VBA.Now + (iWochen * 7)
Selection.NumberFormat = "m/d/yyyy"
End Function
Sub Outlook_Notiz()
'VBA-Zugriff auf Outlook.
'Anwendung: z.B. wenn Activecell Hyperlink ist
Dim olApp As Object, oNewNote As Object
Dim sNoteText As String
sNoteText = "TEST"
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Else
Set olApp = GetObject(, "Outlook.Application")
End If
Set oNewNote = olApp.CreateItem(outlook.olNoteItem)
With oNewNote
.body = sNoteText
.Color = outlook.olBlue
.Display
'.Close (olSave)
End With
Set olApp = Nothing
Set oNewNote = Nothing
End Sub
'2011-07-22
'used for correction MS Symbolic Link (SYLN-) files created by Diagnose_DB Tool
'SYLN-Files started with two characters 'ID' e.g. 'ID_DiagnosticsSet'
'
Sub TestReplaceTextInFile()
ReplaceTextInFile ThisWorkbook.Path & "\ReplaceInTextFile.csv", "ID_DiagnosticsSet", "'ID_DiagnosticsSet"
'ReplaceTextInFile ThisWorkbook.Path & "\ReplaceInTextFile.txt", "|", ";"
'replaces all pipe-characters (|) with semicolons (;)
End Sub
'2011-07-22
'The macros below can be used to replace text in a text file, e.g. when you want to change a column
'separator in a text file before you import it into an Excel worksheet or after you export a worksheet to a text file.
Sub ReplaceTextInFile(SourceFile As String, sText As String, rText As String)
Dim TargetFile As String, tLine As String, tString As String
Dim p As Integer, i As Long, F1 As Integer, F2 As Integer
TargetFile = "RESULT.TMP"
If Dir(SourceFile) = "" Then Exit Sub
If Dir(TargetFile) <> "" Then
On Error Resume Next
Kill TargetFile
On Error GoTo 0
If Dir(TargetFile) <> "" Then
MsgBox TargetFile & _
" already open, close and delete / rename the file and try again.", _
vbCritical
Exit Sub
End If
End If
F1 = FreeFile
Open SourceFile For Input As F1
F2 = FreeFile
Open TargetFile For Output As F2
i = 1 ' line counter
Application.StatusBar = "Reading data from " & _
TargetFile & " ..."
While Not EOF(F1)
If i Mod 100 = 0 Then Application.StatusBar = _
"Reading line #" & i & " in " & _
TargetFile & " ..."
Line Input #F1, tLine
If sText <> "" Then
ReplaceTextInString tLine, sText, rText
End If
Print #F2, tLine
i = i + 1
Wend
Application.StatusBar = "Closing files ..."
Close F1
Close F2
Kill SourceFile ' delete original file
Name TargetFile As SourceFile ' rename temporary file
Application.StatusBar = False
End Sub
'2011-07-22
Private Sub ReplaceTextInString(SourceString As String, _
SearchString As String, ReplaceString As String)
Dim p As Integer, NewString As String
Do
p = InStr(p + 1, UCase(SourceString), UCase(SearchString))
If p > 0 Then ' replace SearchString with ReplaceString
NewString = ""
If p > 1 Then NewString = Mid(SourceString, 1, p - 1)
NewString = NewString + ReplaceString
NewString = NewString + Mid(SourceString, _
p + Len(SearchString), Len(SourceString))
p = p + Len(ReplaceString) - 1
SourceString = NewString
End If
If p >= Len(NewString) Then p = 0
Loop Until p = 0
End Sub
'2011-12-20
'Internet Explorer: private Homepage hinzufügen (wird von VeriFone profile ständig gelöscht)
Sub SecondaryStartPages()
Const IEpath = "HKCU\SOFTWARE\Microsoft\Internet Explorer\Main\Secondary Start Pages"
Const IEvalue = "www.gries.name/Michael/Gries.shtm"
RegWrite IEpath, IEvalue
End Sub
'2011-12-20
'Screensaver ändern (wird von VeriFone profile ständig gesetzt)
Sub ScreenSaverIsSecure()
Const IEpath = "HKCU\SOFTWARE\Policies\Microsoft\Windows\Control Panel\Desktop\ScreenSaverIsSecure"
Const IEvalue = "0"
RegWrite IEpath, IEvalue
End Sub
'2011-12-20
' Schreibt den Wert aus "Value" als den Typ aus "Typ"
' in den in "Path" angegebenen Schlüssel
Public Function RegWrite(ByVal Path As String, _
ByVal Value As String, _
Optional ByVal Typ As String = "REG_SZ") As Boolean
Dim ws As Object
On Error GoTo ErrHandler
Set ws = CreateObject("WScript.Shell")
ws.RegWrite Path, Value, Typ
RegWrite = True
Exit Function
ErrHandler:
RegWrite = False
End Function
Attribute VB_Name = "Menüs_Applikation"
Option Explicit
'(c)2005, Michael Gries
'Update 2011-01-11
Function Check_User_Applikation() As Boolean
Debug.Print GetEnvironComputername
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
cUser.Add True, "Michael" 'Privat
cUser.Add True, "MichaelG12" 'Privat
cUser.Add True, "Stefanie" 'Privat
cUser.Add True, "mgries" 'Michael Gries
cUser.Add True, "Hypercom" 'Michael Gries
cUser.Add True, "bporoffsche" 'Bernd Poroffscheck
cUser.Add True, "mmueller" 'Marco Müller
cUser.Add True, "araschke" 'Anne-Kathrin Raschke
cUser.Add True, "pflorack" 'Peter Florack
'Sonstige
' cUser.Add False, "Kleinwächter" 'Jörg Kleinwächter
' cUser.Add False, "wtonko" 'Walter Tonko
' cUser.Add True, "snuhn" 'Sascha Nuhn
' cUser.Add True, "jhenningsen" 'Jennifer Hennigsen
' cUser.Add True, "pkuhn" 'Peter Kuhn
' cUser.Add True, "mblasl" 'Michael Blasl
' cUser.Add True, "fstolle" 'Falk Stolle
On Error GoTo Err
Check_User_Applikation = cUser(strUserName)
Exit Function
Err:
Check_User_Applikation = False
End Function
Sub ApplikationsMenüErstellen()
If Check_User_Applikation Then
Dim i As Integer
Dim j As Integer
Dim CB_App As CommandBarControl
Dim CB_UApp As CommandBarControl
Dim CB_Upopup As CommandBarControl
Const csAppMenuTitle = "&Quality"
'MenueBars
Dim MB As CommandBarControl
'Set MB = Application.CommandBars("System").Controls.Add
' With MB
' .Caption = "zu Favoriten hinzufügen"
' .OnAction = "LinkToFavorites"
' .BeginGroup = True
' End With
'Set MB = Application.CommandBars("Ply").Controls.Add
' With MB
' .Caption = "Zellbereich freigeben"
' .OnAction = "ClearScrollArea"
' .BeginGroup = True
' End With
Set MB = Nothing
'Applikationsmenu anlegen
'Application.CommandBars("Worksheet Menu Bar").Reset
'Alternativ (alle Einträge werden nicht entfernt)
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar") _
.Controls("Applikation").Delete
i = Application.CommandBars(1).Controls.Count
'j = Application.CommandBars(1).Controls(i).Index
'Alternativ: vor Hilfe (?) Untermenü
j = Application.CommandBars(1).Controls("?").Index
Set CB_App = Application.CommandBars(1).Controls.Add _
(Type:=msoControlPopup, Before:=j)
CB_App.Caption = csAppMenuTitle
'Applikations Untermenu erstellen
'Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
' With CB_UApp
' .Caption = "Anfragen Übersicht"
' .Style = msoButtonIconAndCaption
' .FaceId = 80 'großes A
' .HyperlinkType = msoCommandBarButtonHyperlinkOpen
' .TooltipText = "G:\R&D\Fuel Pumps\Entwicklung\Anfragen\!Anfragenübersicht.xls"
' .BeginGroup = True
' End With
'Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
' With CB_UApp
' .Caption = "Klarstellungen Übersicht"
' .Style = msoButtonIconAndCaption
' .FaceId = 90 'großes K oder 36 Filmstreifen
' .HyperlinkType = msoCommandBarButtonHyperlinkOpen
' '.TooltipText = "http://www.siemensvdo.de"
' '.TooltipText = "G:\R&D\Fuel Pumps\Entwicklung\Klarstellungen\!Vorlagen\Klarstellungen.xls"
' .TooltipText = "G:\R&D\Fuel Pumps\Public_K\KP_Aufwandsabschaetzung\Aufträge&Klarstellungen\Klarstellungen.xls"
' .BeginGroup = False
' End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Autofilter"
.Style = msoButtonIconAndCaption
.OnAction = "Set_Autofilter"
.State = msoButtonUp
.FaceId = 370
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "Formeln"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: Jahr-Monat (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonth"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: Jahr-Monat-Tag (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonthDay"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: HGN (8-stellig)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_HGN"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: EPP V6 - RTC (command n)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_RTC"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "PPM-Performance (WN)"
.Style = msoButtonIconAndCaption
.FaceId = 95 'großes P
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "monatliche Trendbetrachtung WN"
.TooltipText = "X:\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\PPM-Performance.xls"
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Übersicht Warenrückläufer"
.Style = msoButtonIconAndCaption
.FaceId = 97 'großes R
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "DoA's Wincor Nixdorf"
.TooltipText = "X:\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\WR-Übersicht 2006-2007.xls"
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Qualitätszahlen ENH (Trendauswertung)"
.Style = msoButtonIconAndCaption
.FaceId = 99 'großes T
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "wöchentlicher Report ENH"
.TooltipText = "L:\QM\QM-UM_\Subcontractors\EN-Hersfeld___vormals_EZH_Bad-Hersfeld_D\Q-Reporting\2009_neu\Summary_PRF-FT2.xls"
.BeginGroup = False
End With
'Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
' With CB_UApp
' .Caption = "&Ankerdaten formatieren..."
' .Style = msoButtonIconAndCaption
' .OnAction = "DateiLaden_Anker"
' .State = msoButtonUp
' .FaceId = 162
' .BeginGroup = True
' End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Qualitätszahlen formatieren..."
.Style = msoButtonIconAndCaption
.OnAction = "DateiLaden_ENH"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Cognos reports - IRIS-Code Analyse..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Cognos reports - Pivot erstellen..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Cognos reports - doppelte S/N markieren..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_MarkDoubleSerialNumbers"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Cognos reports - mehrfach S/N markieren..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_MultipleSerialNumbers"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&SAP reports - Gruppierung erstellen..."
.Style = msoButtonIconAndCaption
.OnAction = "SAP_ExcelReports_grouping"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&EPP V6 Logfiles formatieren..."
.Style = msoButtonIconAndCaption
.OnAction = "DateiLaden_Logfiles"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Bilder laden..."
.Style = msoButtonIconAndCaption
.OnAction = "Convert_WMF_Dateien"
.State = msoButtonUp
.FaceId = 703 'mehrere Diagramme(oder 303)
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&rote Markierung..."
.Style = msoButtonIconAndCaption
.OnAction = "Add_Shape"
.State = msoButtonUp
.FaceId = 701 '???
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Hypercom Logo"
.Style = msoButtonIconAndCaption
.OnAction = "Insert_HypercomLogo"
.State = msoButtonUp
.FaceId = 6376 'ABC Symbol
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Tag &Aktualisieren"
.Style = msoButtonIconAndCaption
.OnAction = "Tag_Aktualisieren"
.State = msoButtonUp
.FaceId = 126
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Tag &Neu Auswählen"
.Style = msoButtonIconAndCaption
.OnAction = "Tag_Neu_Auswählen"
.State = msoButtonUp
.FaceId = 125
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Monats&kalender Strg+Ums+K"
.Style = msoButtonIconAndCaption
.OnAction = "MonthViewer"
.State = msoButtonUp
.FaceId = 1992 'Kalendersymbol
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Zeilen-Cursor"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Zeilen-Cursor setzen"
.TooltipText = "richtet einen Event Funktion im Arbeitsblatt ein"
.Style = msoButtonIconAndCaption
.OnAction = "AddEventZeilenweiseMarkierenExtern"
.State = msoButtonDown
.FaceId = 293
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Zeilen-Cursor löschen"
.TooltipText = "richtet einen Event Funktion im Arbeitsblatt ein"
.Style = msoButtonIconAndCaption
.OnAction = "RemoveEventZeilenweiseMarkierenExtern"
.State = msoButtonUp
.FaceId = 293
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Spalten Gruppieren"
.Style = msoButtonIconAndCaption
.OnAction = "SpaltenGruppieren"
.State = msoButtonUp
.FaceId = 371
'.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Zeilen Gruppieren"
.Style = msoButtonIconAndCaption
.OnAction = "ZeilenGruppieren"
.State = msoButtonUp
.FaceId = 372
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Gitternetzlinien An/Aus"
.TooltipText = "Toggle Funktion"
.Style = msoButtonIconAndCaption
.OnAction = "GitternetzAnAus"
.State = msoButtonDown
.State = Not .State
.FaceId = 151
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Status formatieren"
.Style = msoButtonIconAndCaption
.OnAction = "Format_Status"
.State = msoButtonUp
.FaceId = 352 'rote Lampe
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Teststatus formatieren"
.Style = msoButtonIconAndCaption
.OnAction = "Format_Testresult"
.State = msoButtonUp
.FaceId = 353 '???
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Mitarbeiter Quality"
.Style = msoButtonIconAndCaption
.OnAction = "Format_Mitarbeiter"
.State = msoButtonUp
.FaceId = 2103 'Männer Kopf
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Kontextmenues"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Kontext &Aktivieren"
.Style = msoButtonIconAndCaption
.OnAction = "OnTimeStart"
.State = msoButtonUp
.FaceId = 346
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Kontext &Beenden"
.Style = msoButtonIconAndCaption
.OnAction = "OnTimeStop"
.State = msoButtonUp
.FaceId = 348
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Farbindex 'Hypercom Grau' setzen"
.TooltipText = "ändert Colorindex 'Aquamarin'"
.Style = msoButtonIconAndCaption
.OnAction = "SetColor_Hypercom_grey"
.State = msoButtonUp
.FaceId = 417
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Farbindex 'Hypercom Blau' setzen"
.TooltipText = "ändert Colorindex 'Dunkelblau'"
.Style = msoButtonIconAndCaption
.OnAction = "SetColor_Hypercom_blue"
.State = msoButtonUp
.FaceId = 417
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = csPrivateMenuTitle & ".xla Version: " & Last_Modified
.TooltipText = Last_Modified
.DescriptionText = "Description Text tbd"
.Style = msoButtonIconAndCaption
.OnAction = Null
.FaceId = 0 'KEIN Symbol
.Enabled = False
.BeginGroup = True
End With
'''Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
''' With CB_UApp
''' .Caption = "hydr. &Messwerte"
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "ASC-Datei(en) &Konvertieren... Strg+Ums+Y"
''' .TooltipText = "Strg+Umsch+Y"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Convert_ASC_Dateien"
''' .FaceId = 300 '300 Tabelle ohne Excel Symbol, 142 mit
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Dateien hydr. Vermessung öffnen"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "DateienHydrVermessungÖffnen"
''' .State = msoButtonUp
''' .FaceId = 142 'Excel Tabellenblatt Symbol
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Deichmann Matrix konvertieren"
''' .TooltipText = " ... in Musterbau Messdatenformat"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Convert_Deichmann_Matrix"
''' .FaceId = 600 'Tabelle alt in neu
''' '.BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Kennlinien erstellen... Strg+Ums+Q"
''' .TooltipText = "aus Musterbau Messdaten (Excel Format)"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "PPT_Diagramm"
''' .FaceId = 422 'Kennlinien Diagramm rot-blau
''' '.BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "ASC-Datei 'Schnelle Messung'"
''' .TooltipText = "für DiaDEM Diagrammerstellung"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "SchnelleMessung"
''' .FaceId = 300 '300 Tabelle ohne Excel Symbol, 142 mit
''' '.BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Kennlinien Übersicht"
''' .Style = msoButtonIconAndCaption
''' .FaceId = 435 'Diagramm und Hand
''' .FaceId = 90 'Großes K
''' .HyperlinkType = msoCommandBarButtonHyperlinkOpen
''' .TooltipText = "G:\R&D\Fuel Pumps\Entwicklung\Kennlinien2\Kunden\!Kennlinienübersicht.xls"
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Prüfungsübersicht"
''' .TooltipText = "für Musteraufträge"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Open_Prüfungsübersicht"
''' .FaceId = 190 'Flußdiagramm Symbol
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Arbeitsanweisung Gries"
''' .Style = msoButtonIconAndCaption
''' .FaceId = 2611 'Großes A mit rotem Unterstrich
''' .HyperlinkType = msoCommandBarButtonHyperlinkOpen
''' '.TooltipText = "http://www.siemensvdo.de"
''' .TooltipText = "\\bber021a\did82006\KP\Pruef_Labor_Daten\" _
''' & "XLA_AddIn_ASCinEXCEL\Arbeitsanweisung Gries.pdf"
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Statistik hinzufügen Strg+Ums+S"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Insert_Statistik"
''' .State = msoButtonUp
''' .FaceId = 308 'Omega Symbol
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Musternummer Sortierung"
''' .Style = msoButtonIconAndCaption
''' .TooltipText = "Musternummern vereinheitlichen"
''' .OnAction = "Format_Muster_Sortierung"
''' .State = msoButtonUp
''' .FaceId = 333
''' ' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Leerspalte hinzufügen"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Empty_Column"
''' .State = msoButtonUp
''' .FaceId = 2175
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Charge hinzufügen/aktualisieren STRG+UMS+C"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Charge"
''' .State = msoButtonUp
''' .FaceId = 2175
''' ' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Zeitselektion hinzufügen/aktualisieren"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Zeitraum"
''' .State = msoButtonUp
''' .FaceId = 2175
''' ' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Prüfwerte &Zusammenführen..."
''' .TooltipText = "mind. zwei Blätter müssen markiert sein"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Concatenate_Sheets"
''' .FaceId = 35 'Zeile mit grünem Pfeil
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Prüfwerte &Formatieren"
''' .TooltipText = "für bessere Lesbarkeit"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Format_Prüfwerte"
''' .FaceId = 9 'Symbol für Zweispaltig
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Spannung interpolieren"
''' .TooltipText = "ausgefüllt"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Voltage"
''' .FaceId = 144 'Ereignis Symbol Dokument
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Enabled = False
''' .Caption = "Spannung extrapolieren"
''' .TooltipText = "ausgefüllt"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Voltage_Extrapoliert"
''' .FaceId = 107 'Ereignis Symbol Dokument (rot)
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Drehzahl interpolieren"
''' .TooltipText = "ausgefüllt"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Speed"
''' .FaceId = 144 'Ereignis Symbol Dokument
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Enabled = True 'freigeschaltet
''' .Caption = "Drehzahl extrapolieren"
''' .TooltipText = "ausgefüllt"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Speed_Extrapoliert"
''' .FaceId = 107 'Ereignis Symbol Dokument (rot)
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Druck interpolieren"
''' .TooltipText = "ausgefüllt"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Pressure"
''' .FaceId = 144 'Ereignis Symbol Dokument
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "&Mittelwerte bilden"
''' .TooltipText = "erstelt neues Sheet"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Add_Mittelwerte"
''' .FaceId = 92 'Großes M
''' .FaceId = 226 '226 Summenzeichen gri.
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Tag &Aktualisieren"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Tag_Aktualisieren"
''' .State = msoButtonUp
''' .FaceId = 126
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Tag &Neu Auswählen"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Tag_Neu_Auswählen"
''' .State = msoButtonUp
''' .FaceId = 125
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "SiemensVDO Logo"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Insert_SiemensVDOLogo"
''' .State = msoButtonUp
''' .FaceId = 6376 'ABC Symbol
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "&Optionen..."
''' .TooltipText = "für jeden PC individuell einstellbar"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Options_Musterbau"
''' .FaceId = 581 'Blitz mit Fenster
''' .BeginGroup = True
''' End With
''' Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
''' With CB_UApp
''' .Caption = "Diagramme"
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Diagramm Trennlinie"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Insert_Musterkopfzeile"
''' .State = msoButtonUp
''' .FaceId = 56 '=Doppelstrich
''' .BeginGroup = False
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Diagramm: Q,I=f(U) Strg+Ums+U"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "QI_U_Diagramm"
''' .State = msoButtonUp
''' .FaceId = 422 'Diagramm
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Diagramm: Q,I=f(n) Strg+Ums+N"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Q_n_Diagramm"
''' .State = msoButtonUp
''' .FaceId = 430 'Diagramm
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Diagramm: Q,I=f(p) Strg+Ums+P"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "QI_p_Diagramm"
''' .State = msoButtonUp
''' .FaceId = 422 'Diagramm
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Diagramm: Histogramm Strg+Ums+H"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Histo_Diagramm"
''' .State = msoButtonUp
''' .FaceId = 433 'Diagramm
''' .BeginGroup = True
''' End With
''' Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
''' With CB_UApp
''' .Caption = "hydr. &Formeln"
''' .BeginGroup = True
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Formel: Wirkungsgrad"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Formel_Wirkungsgrad"
''' .State = msoButtonUp
''' .FaceId = 26 'Formelsymbol "Wurzel"
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Formel: elektrische Leistung"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Formel_elektrischeLeistung"
''' .State = msoButtonUp
''' .FaceId = 26 'Formelsymbol "Wurzel"
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Formel: hydraulische Leistung"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Formel_hydraulischeLeistung"
''' .State = msoButtonUp
''' .FaceId = 26 'Formelsymbol "Wurzel"
''' End With
''' Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
''' With CB_Upopup
''' .Caption = "Formel: Treibstrahlmenge SSP"
''' .Style = msoButtonIconAndCaption
''' .OnAction = "Formel_TreibstrahlmengeSSP"
''' .State = msoButtonUp
''' .FaceId = 26 'Formelsymbol "Wurzel"
''' .BeginGroup = True
''' End With
'Resourcen freigeben
Set CB_App = Nothing
Set CB_UApp = Nothing
Set CB_Upopup = Nothing
End If
End Sub
Public Sub ZellenkontextmenüErgänzen()
Dim MB As CommandBarControl
Dim CBR As CommandBarControl
Dim CBRS As CommandBarControl
Application.CommandBars("Row").Reset 'zunächst Kontextmenü zurücksetzen
On Error Resume Next
If Test_Dateimerkmale_Prüfstand("Typ:", "Kunde:", "Muster") Then
Set MB = Application.CommandBars("Row").Controls.Add
With MB
.FaceId = 35 'mit Hilfe von "SmartTools IconHelp v1.00" ermittelt
.Caption = "zu Messergebnisse.xls hinzufügen"
.TooltipText = "hydr. Messdaten am Dateiende anhängen"
.OnAction = "ZuDateiMessergebnisseHinzufügen"
.BeginGroup = True
End With
'End If
'Statistik-Unterstützung
Set CBR = Application.CommandBars("Row").Controls.Add(Type:=msoControlPopup)
With CBR
.Caption = "&Statistik"
End With
Set CBRS = CBR.Controls.Add(Type:=msoControlButton)
With CBRS
.FaceId = 142 'Symbol Excel-Datei
.Caption = "Statistik 1"
.TooltipText = "hydr. Messdaten am Dateiende anhängen"
.OnAction = "Stat1"
'.BeginGroup = True
End With
Set CBRS = CBR.Controls.Add(Type:=msoControlButton)
With CBRS
.FaceId = 142 'Symbol Excel-Datei
.Caption = "Statistik 2"
.TooltipText = "hydr. Messdaten am Dateiende anhängen"
.OnAction = "Stat2"
'.BeginGroup = True
End With
Set CBRS = CBR.Controls.Add(Type:=msoControlComboBox)
With CBRS
Dim sAction As String
.AddItem Text:="DPI", Index:=1
.AddItem Text:="HPI", Index:=2
.DropDownLines = 3
.DropDownWidth = 120
.Width = 150
.ListIndex = 2
.ListHeaderCount = 0
sAction = "Statistik " & .Index
.OnAction = sAction
'.BeginGroup = True
End With
End If
Call OnTimeStart
End Sub
'Private ctlComboBoxHandler As New ComboBoxHandler
'Sub AddComboBox()
'
' Set HostApp = Application
'
' Dim newBar As Office.CommandBar
' Set newBar = HostApp.CommandBars.Add(Name:="Test CommandBar", Temporary:=True)
' Dim newCombo As Office.CommandBarComboBox
' Set newCombo = newBar.Controls.Add(msoControlComboBox)
' With newCombo
' .AddItem "First Class", 1
' .AddItem "Business Class", 2
' .AddItem "Coach Class", 3
' .AddItem "Standby", 4
' .DropDownLines = 5
' .DropDownWidth = 75
' .ListHeaderCount = 0
' End With
' ctlComboBoxHandler.SyncBox newCombo
' newBar.Visible = True
'
'
'End Sub
Sub Statistik(ByVal Index As Integer)
MsgBox Index
End Sub
Sub Print_Menues()
Dim m As Long
For m = 1 To Application.CommandBars.Count
Debug.Print m & ": " & Application.CommandBars(m).Name
Next m
End Sub
Sub Test_Menue_Adding()
Dim MB As CommandBarControl
Set MB = Application.CommandBars("Pictures Context Menu").Controls.Add
With MB
.Caption = "zu Favoriten hinzufügen"
.OnAction = "LinkToFavorites"
.BeginGroup = True
End With
End Sub
Sub ResetAllCommandBars()
'Kontextmenüs zurücksetzen
With Application
.CommandBars("Worksheet Menu Bar") _
.Reset 'Hauptmenü
.CommandBars("Cell").Reset '(1) Zellen
.CommandBars("System").Reset '(2) System
.CommandBars("Toolbar List").Reset '(3) Menü- und Symbolleisten
.CommandBars("Ply").Reset '(4) Registerkarten
.CommandBars("Column").Reset '(5) Spalten
.CommandBars("Row").Reset '(6) Zeilen
.CommandBars("Chart").Reset '(?) Diagramm
.CommandBars("Reviewing").Reset
.CommandBars("Reviewing").Visible = False '2011-02-13
End With
End Sub
Attribute VB_Name = "Menüs_BBRaun"
'(c)2013, Michael Gries, 2013-03-01
'Letzte Änderung: 2013-03-01
'
Option Explicit
Const csMenüName As String = "&B.Braun"
'
'End Deklarationen
Function Check_User_BBraun() As Boolean 'und Analyse
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
'Admin
cUser.Add True, "Administrator"
cUser.Add True, "griemide"
'Quality
cUser.Add True, "burgpade" 'Patricia Burgmaier 2013-03-01
cUser.Add True, "schnsode" 'Sonja Schneider 2013-03-01
On Error GoTo Err
Check_User_BBraun = cUser(strUserName)
On Error GoTo Err_Log
'Logfile
'Makrosammlung_Gries.Append_Data_To_HYC_Logfile "Gries.xla 2011 Hypercom GmbH"
Exit Function
Err:
Check_User_BBraun = False
Exit Function
Err_Log:
Debug.Print "ERROR: ", Err.Number, Err.Description
Const csContact = "Contact: Michael Gries, -1642"
Dim sText: sText = Err.Description & vbCr & csContact
Dim sResult
sResult = MsgBox(sText, vbCritical, "Menüs_BBraun")
End Function
Sub Menü_BBraun()
If Check_User_BBraun Then
Dim CB_App As CommandBarControl
Dim CB_UApp As CommandBarControl
Dim CB_Upopup As CommandBarControl
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar") _
.Controls(csMenüName).Delete
' Caution: Scottsdale Excel version does nort have '?' in Standard Menue Bar
' Dim i: i = Application.CommandBars(1).Controls("?").Index
' Set CB_App = Application.CommandBars(1).Controls.Add _
' (Type:=msoControlPopup, Before:=i
Set CB_App = Application.CommandBars(1).Controls.Add _
(Type:=msoControlPopup)
CB_App.Caption = csMenüName
'
'Standard-Menü
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Autofilter"
.Style = msoButtonIconAndCaption
.OnAction = "Set_AutofilterCognosType"
.State = msoButtonUp
.FaceId = 370
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Share auf Laufwerk J:"
.Style = msoButtonIconAndCaption
.OnAction = "AutoPivotChart"
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "Share auf Laufwerk J:"
.TooltipText = "\\bhewvfile1\share"
.State = msoButtonUp
.FaceId = 89 'großes J
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "AutoPivot&Chart"
.Style = msoButtonIconAndCaption
.OnAction = "AutoPivotChart"
.State = msoButtonUp
.FaceId = 6450 'Chart Symbol
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Save Cognos to Excel"
.Style = msoButtonIconAndCaption
.OnAction = "FileFormat_Cognos_SaveAs_XLS"
.State = msoButtonUp
.FaceId = 3 'Save Symbol
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Document properties update"
.TooltipText = "ausgefüllt"
.Style = msoButtonIconAndCaption
.OnAction = "Add_Dokumenteigenschaften_Hypercom"
.FaceId = 144 'Ereignis Symbol Dokument
.BeginGroup = False
End With
'Abteilungsspezifische Untermenüs erstellen
'
'Application
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Application"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Open Ladedatenbank (LDB) CSV-Files..."
.Style = msoButtonIconAndCaption
.OnAction = "Open_CSV_Files_LDB"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Open Diagnose_DB (DDT) CSV-Files..."
.Style = msoButtonIconAndCaption
.OnAction = "Open_CSV_Files_DDT"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
'Global Product Support
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Global Product Support"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Shipped Order Details - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_SOD_GPS"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analysis..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: MORP - Code Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_IRIS_Report.Mapping_MORP_Code"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = True
End With
'
'ProductManagement
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Product Management"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Commercial Configurator (AHT)"
.Style = msoButtonIconAndCaption
.FaceId = 82 'großes C
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "GE2306_AHT_Commercial_Configurator_2010-V4.xls"
.TooltipText = "L:\Company\Produkte\Artema_Hybrid\Commercial_Configurator\GE2306_AHT_Commercial_Configurator_2010-V4.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Shipped Order Details - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_SOD"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Serial Number List - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_SNL"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Format: Jahr-&Monat (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonth"
.State = msoButtonUp
.FaceId = 372 'Spalte mit Pfeil nach unten"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Status formatieren"
.Style = msoButtonIconAndCaption
.OnAction = "Format_Status"
.State = msoButtonUp
.FaceId = 352 'rote Lampe
.BeginGroup = False
End With
'
'Quality Management
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Quality"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Accounts"
.Style = msoButtonIconAndCaption
.FaceId = 80 'großes A
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "official oganization site"
.TooltipText = "L:\QM\Hypercom Chart of Accounts 3-31-10.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "IRIS-Codes (www.iriscode.org)"
.Style = msoButtonIconAndCaption
.FaceId = 82 'großes C
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "official oganization site"
.TooltipText = "http://www.iriscode.org/IrisCode.exe?Sid=.20110605230956656&action=file&name=pdf/EN_IRIS_03.12.22.pdf"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "PPM-Performance (WN)"
.Style = msoButtonIconAndCaption
.FaceId = 95 'großes P
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "monatliche Trendbetrachtung WN"
'.TooltipText = "X:\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\PPM-Performance.xls"
'.TooltipText = "\\bhelxfile2\xfer\"
.TooltipText = "\\bhelxfile2\xfer\transfer_enh\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\PPM-Performance.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Warenrückläufer - Wincor Nixdorf (WN)"
.Style = msoButtonIconAndCaption
.FaceId = 102 'großes W
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "monatliche Trendbetrachtung WN"
'.TooltipText = "X:\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\WR_Übersicht.xls"
.TooltipText = "\\bhelxfile2\xfer\transfer_enh\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\WR_Übersicht.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Amdocs report - IRIS Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "AmdocsReports_IRIS_Pivot_WN"
.State = msoButtonUp
.FaceId = 7
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Status Quo - QM - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RSQ_QM"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analyse KEBA..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code_KEBA"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analyse WN..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code_WN"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: S/W Load Date (based on HSM_LIFELINE DB)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_SwLoadDate"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: 1st Shipped (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_1stShipped"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: HGN (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_HGN_Sub"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Item Revision (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_Rev"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Datecode (based on DIN EN 60062)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_Datecode"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: EMS Partner ID (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_EMS"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Pivot Chart formatting..."
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Format_PivotChart"
.State = msoButtonUp
.FaceId = 17 'Chart Symbol
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Fault Tree - Group ID Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Mapping_FaultTree"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: HGN (8-stellig)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_HGN"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
'
'SalesOrderProcessing
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Sales Order Processing"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Open Orders Snapshot - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - On Hand Quantity - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_OHQ"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
'
'Service&Repair
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "Service && &Repair"
.FaceId = 97 'großes R !!!! will not work here
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Anleitung - Grt Oracle Repair Tool (GORT)"
.Style = msoButtonIconAndCaption
.FaceId = 80 'großes A
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "Anleitung - Grt Oracle Repair Tool (GORT)"
.TooltipText = "L:\KV\KVR\GORT\GORT_V2.doc"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "IRIS-Codes (www.iriscode.org)"
.Style = msoButtonIconAndCaption
.FaceId = 82 'großes C
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "official oganization site"
.TooltipText = "http://www.iriscode.org/IrisCode.exe?Sid=.20110605230956656&action=file&name=pdf/EN_IRIS_03.12.22.pdf"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Übersicht &Wartungsstufen (Repair Level)"
.Style = msoButtonIconAndCaption
.FaceId = 102 'großes W
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "Übersicht Wartungsstufen (Repair Level)"
.TooltipText = "L:\KV\KVR\_Übersicht Wartungsstufen\Repair Level - CrossReference.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Status Quo - Service Provider"
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RSQ_SP"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Status Quo - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RSQ"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Fault Code - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RFC"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Fault Code - Revenue..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RFC_Revenue"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analyse..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Repair &Level - Code Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Mapping_RepairLevel"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Repair Record &Type - Code Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Mapping_RepairRecordType"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Serial Number - Marking uniqueless"
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Add_MarkingUniquelessSerialNumbers"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Repair Orders - Marking uniqueless"
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Add_MarkingUniquelessRepairOrders"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Format: Jahr-&Monat (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonth"
.State = msoButtonUp
.FaceId = 372 'Spalte mit Pfeil nach unten"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Format: Jahr-Monat-&Tag (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonthDay"
.State = msoButtonUp
.FaceId = 372 'Spalte mit Pfeil nach unten"
End With
'
'Standardmenü unten
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "B.Braun &Logo"
.Style = msoButtonIconAndCaption
.OnAction = "Insert_BBraun_Logo"
.State = msoButtonUp
.FaceId = 6376 'ABC Symbol
.BeginGroup = True
End With
'
'Ausgabestand
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = csPrivateMenuTitle & ".xla Version: " & Last_Modified
.TooltipText = Last_Modified
.Style = msoButtonIconAndCaption
.OnAction = Null
.FaceId = 0 'KEIN Symbol
.Enabled = False
.BeginGroup = True
End With
'Resourcen freigeben
Set CB_App = Nothing
Set CB_UApp = Nothing
Set CB_Upopup = Nothing
End If
End Sub
'2011-01-16
Sub Add_Dokumenteigenschaften_Hypercom()
Dim sComment As String: sComment = "Usage of 'Gries.xla' " & Last_Modified
Call Modul_Pivot.Add_AuthorInfo(sComment)
Application.Dialogs(xlDialogProperties).Show
End Sub
''''2011-01-16
'''Function Mapping_User_to_Username() As String
''' Mapping_User_to_Username = "" 'default
''' Dim strUserName As String: strUserName = GetUserLoginName()
''' Dim cUser As New Collection
''' 'Quality
''' cUser.Add "Michael Gries", "mgries" 'it's me
''' cUser.Add "Anne-Kathrin Raschke", "araschke" 'Anne-Kathrin Raschke
''' 'Supply Chain
''' cUser.Add "Bernd Poroffscheck", "bporoffsche" 'Improvement Engineer
''' cUser.Add "Marco Müller", "mmueller" '
''' 'Service&Repair
''' cUser.Add "Georg Niemann", "gniemann" 'Head of Service&Repair
''' cUser.Add "Falk Stolle", "fstolle" 'Project Leader
''' cUser.Add "Michael Blasl", "mblasl" 'Manager
''' cUser.Add "Jennifer Henningsen", "jhenningsen" 'Apprentice
''' cUser.Add "Nathalie Dunst", "ndunst" 'vormals Schwemmlein
''' 'SOP
''' cUser.Add "Peter Kuhn", "pkuhn" 'Peter Kuhn
''' 'PM
''' cUser.Add "Horst Bernshausen", "hbernshause" 'Product Manager
''' cUser.Add "Peter Florack", "pflorack" 'Technical Key Account
''' 'GPS
''' cUser.Add "Tom Detras", "TDetras" 'Head of GPS
''' cUser.Add "Ralene Yesenski", "RYesenski" 'nice lady
''' On Error Resume Next
''' Mapping_User_to_Username = cUser(strUserName)
'''End Function
'2011-11-21
Function Mapping_User_to_Username() As String
Mapping_User_to_Username = "" 'default
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
'Quality
cUser.Add "Michael Gries", "MichaelG12" 'it's me
cUser.Add "Anne-Kathrin Raschke", "araschke" 'Wareneingang
cUser.Add "Reinhold Pfeffer", "ReinholdP1" 'Lokales Qualitätsmanagement
cUser.Add "Norbert Köhler", "NorbertK1" 'Lokales Qualitätsmanagement
'Supply Chain
cUser.Add "Bernd Poroffscheck", "bporoffsche" 'Improvement Engineer
cUser.Add "Marco Müller", "mmueller" '
'Service&Repair
cUser.Add "Georg Niemann", "gniemann" 'Head of Service&Repair
cUser.Add "Falk Stolle", "fstolle" 'Project Leader
cUser.Add "Michael Blasl", "mblasl" 'Manager
'SOP
cUser.Add "Peter Kuhn", "pkuhn" 'Peter Kuhn
'PM
cUser.Add "Horst Bernshausen", "hbernshause" 'Product Manager
cUser.Add "Peter Florack", "pflorack" 'Technical Key Account
On Error Resume Next
Mapping_User_to_Username = cUser(strUserName)
End Function
''''2011-01-16
'''Function Mapping_User_to_Manager() As String
''' Mapping_User_to_Manager = "" 'default
''' Dim strUserName As String: strUserName = GetUserLoginName()
''' Dim cUser As New Collection
''' 'Quality
''' cUser.Add "TK Cheung", "mgries"
''' cUser.Add "Michael Gries", "araschke" 'Anne-Kathrin Raschke
''' 'Supply Chain
''' cUser.Add "Michael Gries", "bporoffsche" 'Bernd Poroffscheck
''' cUser.Add "Michael Gries", "mmueller" 'Marco Müller
''' 'Service&Repair
''' cUser.Add "Benno Rach", "gniemann" 'Georg Niemann
''' cUser.Add "Georg Niemann", "fstolle" 'Falk Stolle
''' cUser.Add "Georg Niemann", "mblasl" 'Michael Blasl
''' cUser.Add "Georg Niemann", "jhenningsen" 'Jennifer Hennigsen
''' 'SOP
''' cUser.Add "Benno Rach", "pkuhn" 'Peter Kuhn
''' 'PM
''' cUser.Add "Norbert Albrecht", "hbernshause" 'Horst Bernshausen
''' cUser.Add "Norbert Albrecht", "pflorack" 'Peter Florack
''' 'GPS
''' cUser.Add "TK Cheung", "TDetras" 'Tom Detras
''' cUser.Add "Tom Detras", "RYesenski" 'Rai Yesenski
''' On Error Resume Next
''' Mapping_User_to_Manager = cUser(strUserName)
'''End Function
'2011-11-21
Function Mapping_User_to_Manager() As String
Mapping_User_to_Manager = "" 'default
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
'Quality
cUser.Add "Don Perkins", "MichaelG12"
cUser.Add "Michael Gries", "T_AnneR1" 'Anne-Kathrin Raschke
cUser.Add "Norbert Albrecht", "ReinholdP1" 'Lokales Qualitätsmanagement
cUser.Add "Reinhold Pfeffer", "NorbertK1" 'Lokales Qualitätsmanagement
'Supply Chain
cUser.Add "Ralf Seger", "BerndP1" 'Bernd Poroffscheck
cUser.Add "Ralf Seger", "MarcoM1" 'Marco Müller
'Service&Repair
cUser.Add "Georg Niemann", "FalkS1" 'Falk Stolle
cUser.Add "Georg Niemann", "MichaelB18" 'Michael Blasl
'SOP
cUser.Add "Markus Hoevekamp", "pkuhn" 'Peter Kuhn
'PM
cUser.Add "Norbert Albrecht", "hbernshause" 'Horst Bernshausen
cUser.Add "Norbert Albrecht", "pflorack" 'Peter Florack
On Error Resume Next
Mapping_User_to_Manager = cUser(strUserName)
End Function
Attribute VB_Name = "Menüs_Gries"
'(c) 2006, Michael Gries
'Erstellung: 2006-01-27 (SVDO)
'Erstellung: 2008-02-28 (Thales)
'Letzte Änderung: 2010-11-22
'
Option Explicit
Public Const csPrivateMenuTitle = "&Gries"
Const csGriesHomeUser As String = "Michael"
'Const csGriesOfficeUser As String = "uidf9246"
Const csGriesOfficeUser As String = "mgries"
'
'End Deklarationen
Sub test()
Application.CommandBars("&Versuch").Reset '(6) Zeilen
End Sub
Sub CheckForPrivateMenue()
Dim strUserName As String
strUserName = GetUserLoginName()
If strUserName = csGriesHomeUser Or _
strUserName = csGriesOfficeUser Or _
Check_User_Admin _
Then
Call PrivateMenüErstellen
Call Makrosammlung_Gries.Standardprofil_Gries
End If
End Sub
'2009-11-28
Function Check_User_Admin() As Boolean 'und Analyse
Dim strAdminName As String: strAdminName = GetUserLoginName()
Dim cUser As New Collection
cUser.Add True, "Michael"
cUser.Add True, "MichaelG12"
cUser.Add True, "mgries"
cUser.Add True, "Hypercom" 'Michael Gries
cUser.Add True, "Stefanie"
cUser.Add True, "Reuber" '
cUser.Add True, "Administrator" '
cUser.Add True, "griemide" '
On Error GoTo Err
Check_User_Admin = cUser(strAdminName)
Exit Function
Err:
Check_User_Admin = False
End Function
Sub PrivateMenüErstellen()
Dim i As Integer
Dim j As Integer
Dim CB_App As CommandBarControl
Dim CB_UApp As CommandBarControl
Dim CB_Upopup As CommandBarControl
'Privates Menü anlegen
'Application.CommandBars("Worksheet Menu Bar").Reset
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar") _
.Controls("Gries").Delete
i = Application.CommandBars(1).Controls.Count
j = Application.CommandBars(1).Controls("Help").Index
Set CB_App = Application.CommandBars(1).Controls.Add _
(Type:=msoControlPopup, Before:=j)
CB_App.Caption = csPrivateMenuTitle
'Private Untermenüs erstellen
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = csPrivateMenuTitle & ".xla Version: " & Last_Modified
.TooltipText = Last_Modified
.Style = msoButtonIconAndCaption
.OnAction = Null
.FaceId = 0 'KEIN Symbol
.Enabled = False
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Internet: Wikibooks - Excel VBA"
.Style = msoButtonIconAndCaption
.FaceId = 84 'großes E
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "http://de.wikibooks.org/wiki/VBA_in_Excel_-_Grundlagen"
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Dokumenteigenschaften"
.TooltipText = "ausgefüllt"
.Style = msoButtonIconAndCaption
.OnAction = "Add_Dokumenteigenschaften_Applikation_Show"
.FaceId = 144 'Ereignis Symbol Dokument
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlComboBox)
With CB_UApp
.Caption = "&Cognos reports - Combo..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
.Style = msoComboLabel
.AddItem "vanilla"
.AddItem "chocolate"
.AddItem "cookie dough"
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlEdit)
With CB_UApp
.Caption = "&Cognos reports - Edit..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Windows Rechner"
.TooltipText = "Calc"
.Style = msoButtonIconAndCaption
.OnAction = "Windows_Rechner"
.FaceId = 960 'Rechner Symbol
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Tabellenblätter einblenden"
.TooltipText = "alle"
.Style = msoButtonIconAndCaption
.OnAction = "View_All_Sheets"
.State = msoButtonDown
.State = Not .State
.FaceId = 125 'zwei Tabellenblätter
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Gitternetzlinien An/Aus"
.TooltipText = "Toggle Funktion"
.Style = msoButtonIconAndCaption
.OnAction = "GitternetzAnAus"
.State = msoButtonDown
'.State = Not .State
'.FaceId = 151
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&ScrollArea Aus"
.TooltipText = "alles freigeben"
.Style = msoButtonIconAndCaption
.OnAction = "ScrollArea_All"
.State = msoButtonUp
.FaceId = 6
'.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Kommentare Strg+Ums+K"
.TooltipText = "Toggle Funktion"
.Style = msoButtonIconAndCaption
.OnAction = "Toggle_Comments"
.State = msoButtonDown
.State = Not .State
.FaceId = 1593 'Kommentar Wechselsymbol oder 1594
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Outlook Notiz"
.TooltipText = "Hyperlink als Notiz in Outlook speichern"
.Style = msoButtonIconAndCaption
.OnAction = "Outlook_Notiz"
.State = msoButtonUp
.FaceId = 1758 'Notiz-Haftzettel
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Farbtabelle"
.TooltipText = "zeigt Übersicht in neuer Mappe"
.Style = msoButtonIconAndCaption
.OnAction = "Farbtabelle"
.State = msoButtonDown
.State = Not .State
.FaceId = 417 'Farbmal Symbol
.BeginGroup = False
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "AddIn: Excel-Hilfen"
.TooltipText = "AddIn: Excel-Hilfen"
.Style = msoButtonIconAndCaption
.OnAction = "Toggle_AddInHerbers"
.State = msoButtonDown
.State = Not .State
.FaceId = 66
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "Formeln"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: EPP V6 - RTC (command n)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_RTC"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Datei Messergebnisse.xls öffnen"
.Style = msoButtonIconAndCaption
.OnAction = "DateiMessergebnisseÖffnen"
.State = msoButtonUp
.FaceId = 142 'Excel Tabellenblatt Symbol
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: Wirkungsgrad"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_Wirkungsgrad"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: hydraulische Leistung"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_hydraulischeLeistung"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: Treibstrahlmenge SSP"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_TreibstrahlmengeSSP"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "EasyLog USB Excel Export Datei formatieren... "
.Style = msoButtonIconAndCaption
.FaceId = 6450 'Chart Symbol
.OnAction = "EasyLog_USB_ExcelExportFile"
.State = msoButtonUp
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "LogFile_Vermessung"
.Style = msoButtonIconAndCaption
.FaceId = 662 'T-Symbol mit weißen Viereck
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
'.TooltipText = "\\bber021a\did82006\KP\Pruef_Labor_Daten\XLA_AddIn_ASCinEXCEL\LogFile_Vermessung.txt"
.TooltipText = "T:\KP\Pruef_Labor_Daten\XLA_AddIn_ASCinEXCEL\LogFile_Vermessung.txt"
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Gleitzeitliste"
.Style = msoButtonIconAndCaption
.FaceId = 86 'großes G
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "\\BBER002A\uidf9246$O$\Vorlage Zeiterfassung_Gries.xls"
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Gries.xla freigeben"
.TooltipText = "auf T: Server kopieren"
.Style = msoButtonIconAndCaption
.OnAction = "Release_Gries_AddIn"
.State = msoButtonDown
.State = Not .State
.FaceId = 263
.BeginGroup = True
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Kontextmenues"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Kontext &Aktivieren"
.Style = msoButtonIconAndCaption
.OnAction = "OnTimeStart"
.State = msoButtonUp
.FaceId = 346
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Kontext &Beenden"
.Style = msoButtonIconAndCaption
.OnAction = "OnTimeStop"
.State = msoButtonUp
.FaceId = 348
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Farbindex 'Siemens Petrol' setzen"
.TooltipText = "ändert Colorindex 'Aquamarin'"
.Style = msoButtonIconAndCaption
.OnAction = "SetColor_Siemens_Petrol"
.State = msoButtonUp
.FaceId = 417
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Farbindex 'VDO Blau' setzen"
.TooltipText = "ändert Colorindex 'Dunkelblau'"
.Style = msoButtonIconAndCaption
.OnAction = "SetColor_VDO_blue"
.State = msoButtonUp
.FaceId = 417
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Farbindex 'Thales Blau' setzen"
.TooltipText = "ändert Colorindex 'Dunkelblau'"
.Style = msoButtonIconAndCaption
.OnAction = "SetColor_VDO_blue"
.State = msoButtonUp
.FaceId = 417
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Farbindex 'Hypercom Blau' setzen"
.TooltipText = "ändert Colorindex 'Dunkelblau'"
.Style = msoButtonIconAndCaption
.OnAction = "SetColor_Hypercom_blue"
.State = msoButtonUp
.FaceId = 417
End With
'Resourcen freigeben
Set CB_App = Nothing
Set CB_UApp = Nothing
Set CB_Upopup = Nothing
End Sub
Sub Print_AddIns()
Dim m As Long
For m = 1 To Application.AddIns.Count
Debug.Print m & ": " & Application.AddIns(m).Name
'Debug.Print m & ": " & Application.AddIns(m).FullName
Next m
End Sub
Sub Toggle_AddInHerbers()
Set a = AddIns("Excel-Recherche")
If a.Installed = True Then
AddIns("Excel-Recherche").Installed = _
Not AddIns("Excel-Recherche").Installed
Else
MsgBox "Add-In ist nicht installiert"
End If
End Sub
Sub ScrollArea_All()
On Error Resume Next 'falls kein Blatt ausgewählt
Application.DisplayStatusBar = True
ActiveSheet.ScrollArea = "" 'Gesamtes Blatt
With ActiveWindow
.DisplayFormulas = False
.DisplayGridlines = True
.DisplayOutline = True
.DisplayZeros = True
.DisplayHeadings = True 'Zeilen- und Spaltenüberschriften
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = True
End With
End Sub
Sub Release_Gries_AddIn()
'Letzte Änderung: 2007-08-11
Const csAddinName As String = "Gries.xla"
Const csOfficeDrive As String = "L:\"
Const csOfficeServer As String = "\\Deheffs001\root$\"
Const csOfficePath As String = "Company\QM_Public\Improvement\CMMI\"
Const csOfficeBackup As String = "\\Deheffs001\gries\"
'SOURCE
'für Laptop Anwendung mittels SVDOsupport.mga
''' Dim sUA As String: sUA = VBA.Environ("APPDATA")
''' Const csUPUA As String = "\Microsoft\Addins\"
''' Dim sSource As String: sSource = sUA & csUPUA & csAddinName
'für Feststation
Dim sUA As String
sUA = VBA.Environ("USERPROFILE")
Const csUPUA As String = "\Eigene Dateien\"
Dim sSource As String
sSource = sUA & csUPUA & csAddinName
'DESTINATION
Dim sDestination As String: sDestination = csOfficeDrive & csOfficePath
'BACKUP
Dim sUD As String: sUD = VBA.Environ("USERPROFILE")
Const csUPUD As String = "\Eigene Dateien\"
Dim sBackupDate As String: sBackupDate = VBA.Format(VBA.Date, "yyyy-mm-dd")
Dim sBackup As String
sBackup = sUD & csUPUD & "Gries." & sBackupDate & ".xla"
If VBA.Environ("USERNAME") = "uidf9246" Then
sSource = csOfficeBackup & csAddinName
sBackup = csOfficeBackup & "Gries." & sBackupDate & ".xla"
End If
'Anpassung an DOS wegen xcopy Befehl (Leerzeichen in Pfadangaben)
' sSource = """" & sSource & """"
' sDestination = """" & sDestination & """"
' sBackup = """" & sBackup & """"
Application.DisplayStatusBar = True
If Modul_WSH.CopyFile(sSource, sBackup) Then
Application.StatusBar = sSource & " nach " & sBackup & " kopiert"
Else
MsgBox "Fehler"
End If
' sShellCommand = _
' "xcopy /y " & sSource & " " & sBackup
' Debug.Print "VBA.shell Command: "
' Debug.Print sShellCommand
' iTaskID = Shell(sShellCommand): Debug.Print iTaskID
' If iTaskID = 0 Then
' MsgBox "Fehler bei (Gries.xla freigeben): " & _
' csAddinName & vbCr & vbCr & _
' sSource & vbCr & _
' sBackup, , ThisWorkbook.Name
' End If
'On Error Resume Next
Modul_WSH.CopyFile sSource, sDestination
On Error GoTo 0
' Dim sShellCommand As String: sShellCommand = _
' "xcopy /y " & sSource & " " & sDestination
' Debug.Print "VBA.shell Command: "
' Debug.Print sShellCommand
' Dim iTaskID: iTaskID = Shell(sShellCommand): Debug.Print iTaskID
' If iTaskID = 0 Then
' MsgBox "Fehler bei (Gries.xla freigeben): " & _
' csAddinName & vbCr & vbCr & _
' sSource & vbCr & _
' sDestination, , ThisWorkbook.Name
' End If
'BACKUP ausführen
End Sub
Sub Scripting_Test()
'Verweis auf "Microsoft Scripting" muss vorhanden sein
' Debug.Print Drive.DriveLetter
End Sub
Attribute VB_Name = "Menüs_Musterbau"
'(c)2006, Michael Gries, 01.01.2006
'Letzte Änderung SVDO: 2007-09-20
'Letzte Änderung HYC: 2011-01-11
'
Option Explicit
Const csMenüName As String = "&Musterbau"
Public Const csServerApplikation As String = "\\bber021a\did82006\"
Public Const csPathApplikation As String = "KP\Pruef_Labor_Daten\XLA_AddIn_ASCinEXCEL\"
'Public Const csServerApplikation As String = "\\bber002a\did82005\"
'Public Const csPathApplikation As String = "R&D\Fuel Pumps\Entwicklung\Applikation\"
'
'End Deklarationen
Function Check_User_Musterbau() As Boolean 'und Analyse
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
cUser.Add True, "Michael"
cUser.Add True, "mgries"
cUser.Add True, "Hypercom" 'Michael Gries
cUser.Add True, "Stefanie"
cUser.Add True, "Reuber" '
'
cUser.Add True, "jhennigsen" 'Jennifer Hennigsen
cUser.Add True, "pkuhn" 'Peter Kuhn
cUser.Add True, "mblasl" 'Michael Blasl
cUser.Add True, "fstolle" 'Falk Stolle
On Error GoTo Err
Check_User_Musterbau = cUser(strUserName)
Exit Function
Err:
Check_User_Musterbau = False
End Function
Sub Menü_Musterbau()
If Check_User_Musterbau Then
Dim CB As CommandBarControl
Dim CB_U As CommandBarControl
Dim CB_Upopup As CommandBarControl
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar") _
.Controls(csMenüName).Delete
Dim i: i = Application.CommandBars(1).Controls("?").Index
Set CB = Application.CommandBars(1).Controls.Add _
(Type:=msoControlPopup, Before:=i)
CB.Caption = csMenüName
'Private Untermenüs erstellen
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "Hypercom Logo"
.Style = msoButtonIconAndCaption
.OnAction = "Insert_HypercomLogo"
.State = msoButtonUp
.FaceId = 6376 'ABC Symbol
.BeginGroup = True
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "ASC-Datei(en) &Konvertieren... Strg+Ums+Y"
.TooltipText = "Strg+Umsch+Y"
.Style = msoButtonIconAndCaption
.OnAction = "Convert_ASC_Dateien"
.FaceId = 300 '300 Tabelle ohne Excel Symbol, 142 mit
.BeginGroup = True
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "Prüfwerte &Zusammenführen... Strg+Ums+Z"
.TooltipText = "mind. zwei Blätter müssen markiert sein"
.Style = msoButtonIconAndCaption
.OnAction = "Concatenate_Sheets"
.FaceId = 35 'Zeile mit grünem Pfeil
.BeginGroup = False
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "&Musterdaten formatieren Strg+Ums+M"
.TooltipText = "Strg+Umsch+M"
.Style = msoButtonIconAndCaption
.OnAction = "Format_Muster"
.FaceId = 123 'Liniensymbol
.BeginGroup = False
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "Tag &Neu Auswählen"
.TooltipText = "Formular"
.Style = msoButtonIconAndCaption
.OnAction = "Tag_Neu_Auswählen"
.FaceId = 125
.BeginGroup = False
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "&Akustikmodul starten"
.Style = msoButtonIconAndCaption
.OnAction = "AkustikmodulLaden"
.State = msoButtonUp
.FaceId = 68 'Lautsprechersymbol
.BeginGroup = True
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "&Prüfungsübersicht"
.TooltipText = "für Musteraufträge"
.Style = msoButtonIconAndCaption
.OnAction = "Open_Prüfungsübersicht"
.FaceId = 190 'Flußdiagramm Symbol
.BeginGroup = True
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "Arbeitsanweisung &Gries"
.Style = msoButtonIconAndCaption
.FaceId = 2611 'Großes A mit rotem Unterstrich
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "\\bber021a\did82006\KP\Pruef_Labor_Daten\" _
& "XLA_AddIn_ASCinEXCEL\Arbeitsanweisung Gries.pdf"
.BeginGroup = False
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "&Prüfstandsbelegung"
.Style = msoButtonIconAndCaption
.FaceId = 263 'Excel Symbol
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "\\bber021a\did82006\KP\Pruef_Labor_Daten\" _
& "Prüfstandsbelegung\Belegung_Prüfstände_02.xls"
.BeginGroup = True
End With
Set CB_U = CB.Controls.Add(Type:=msoControlButton)
With CB_U
.Caption = "&Optionen..."
.TooltipText = "für jeden PC individuell einstellbar"
.Style = msoButtonIconAndCaption
.OnAction = "Options_Musterbau"
.FaceId = 581 'Blitz mit Fenster
.BeginGroup = True
End With
'Resourcen freigeben
Set CB = Nothing
Set CB_U = Nothing
Set CB_Upopup = Nothing
End If
End Sub
Sub Open_Prüfungsübersicht()
Const csDatei As String = "Prüfungsübersicht.xls"
Application.Workbooks.Open csServerApplikation & csPathApplikation & csDatei
End Sub
Sub Options_Musterbau()
Form_Musterbau.Show vbModeless
End Sub
Attribute VB_Name = "Menüs_VeriFone"
'(c)2011, Michael Gries, 2011-01-10
'Letzte Änderung: 2012-02-25
'
Option Explicit
Const csMenüName As String = "&VeriFone"
'
'End Deklarationen
Function Check_User_Hypercom() As Boolean 'und Analyse
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
'Admin
cUser.Add True, "mgries"
cUser.Add True, "MichaelG12" 'Michael Gries 2011-11-21
'Quality
cUser.Add True, "ReinholdP1" 'Reinhold Pfeffer 2011-11-21
cUser.Add True, "NorbertK1" 'Norbert Köhler 2011-11-21
cUser.Add True, "araschke" 'Anne-Kathrin Raschke
cUser.Add True, "T_Anner1" 'Anne-Kathrin Raschke 2011-11-21
cUser.Add True, "bporoffsche" 'Bernd Poroffscheck
cUser.Add True, "BerndP1" 'Bernd Poroffscheck 2011-11-21
cUser.Add True, "mmueller" 'Marco Müller
cUser.Add True, "MarcoM2" 'Marco Müller 2011-11-21
'Service&Repair
cUser.Add True, "gniemann" 'Georg Niemann 2011-02-16
cUser.Add True, "fstolle" 'Falk Stolle 2010-12-06
cUser.Add True, "FalkS1" 'Falk Stolle 2010-12-06
cUser.Add True, "mblasl" 'Michael Blasl 2011-01-14
cUser.Add True, "MichaelB18" 'Michael Blasl 2011-11-21
cUser.Add True, "snuhn" 'Sascha Nuhn 2011-06-15
cUser.Add True, "jhenningsen" 'Jennifer Hennigsen 2011-01-04
cUser.Add True, "ndunst" 'Nathalie Dunst 2011-02-01
'SOP
cUser.Add True, "pkuhn" 'Peter Kuhn
cUser.Add True, "PeterK5" 'Peter Kuhn 2011-11-21
'PM
cUser.Add True, "hbernshause" 'Horst Bernshausen 2011-01-11
cUser.Add True, "HorstB1" 'Horst Bernshausen 2011-11-21
cUser.Add True, "pflorack" 'Peter Florack 2011-01-29
cUser.Add True, "PeterF1" 'Peter Florack 2011-11-21
'GPS
cUser.Add True, "TDetras" 'Tom Detras 2011-03-08
cUser.Add True, "RYesenski" 'Rai Yesenski 2011-03-08
On Error GoTo Err
Check_User_Hypercom = cUser(strUserName)
On Error GoTo Err_Log
'Logfile
'Makrosammlung_Gries.Append_Data_To_HYC_Logfile "Gries.xla 2011 Hypercom GmbH"
Exit Function
Err:
Check_User_Hypercom = False
Exit Function
Err_Log:
Debug.Print "ERROR: ", Err.Number, Err.Description
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = Err.Description & vbCr & csContact
Dim sResult
sResult = MsgBox(sText, vbCritical, "Menüs_VeriFone")
End Function
Sub Menü_VeriFone()
If Check_User_Hypercom Then
Dim CB_App As CommandBarControl
Dim CB_UApp As CommandBarControl
Dim CB_Upopup As CommandBarControl
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar") _
.Controls(csMenüName).Delete
' Caution: Scottsdale Excel version does nort have '?' in Standard Menue Bar
' Dim i: i = Application.CommandBars(1).Controls("?").Index
' Set CB_App = Application.CommandBars(1).Controls.Add _
' (Type:=msoControlPopup, Before:=i
Set CB_App = Application.CommandBars(1).Controls.Add _
(Type:=msoControlPopup)
CB_App.Caption = csMenüName
'
'Standard-Menü
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "&Autofilter"
.Style = msoButtonIconAndCaption
.OnAction = "Set_AutofilterCognosType"
.State = msoButtonUp
.FaceId = 370
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Share auf Laufwerk J:"
.Style = msoButtonIconAndCaption
.OnAction = "AutoPivotChart"
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "Share auf Laufwerk J:"
.TooltipText = "\\bhewvfile1\share"
.State = msoButtonUp
.FaceId = 89 'großes J
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "AutoPivot&Chart"
.Style = msoButtonIconAndCaption
.OnAction = "AutoPivotChart"
.State = msoButtonUp
.FaceId = 6450 'Chart Symbol
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Save Cognos to Excel"
.Style = msoButtonIconAndCaption
.OnAction = "FileFormat_Cognos_SaveAs_XLS"
.State = msoButtonUp
.FaceId = 3 'Save Symbol
End With
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "Document properties update"
.TooltipText = "ausgefüllt"
.Style = msoButtonIconAndCaption
.OnAction = "Add_Dokumenteigenschaften_Hypercom"
.FaceId = 144 'Ereignis Symbol Dokument
.BeginGroup = False
End With
'Abteilungsspezifische Untermenüs erstellen
'
'Application
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Application"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Open Ladedatenbank (LDB) CSV-Files..."
.Style = msoButtonIconAndCaption
.OnAction = "Open_CSV_Files_LDB"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Open Diagnose_DB (DDT) CSV-Files..."
.Style = msoButtonIconAndCaption
.OnAction = "Open_CSV_Files_DDT"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
'Global Product Support
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Global Product Support"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Shipped Order Details - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_SOD_GPS"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analysis..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: MORP - Code Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_IRIS_Report.Mapping_MORP_Code"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = True
End With
'
'ProductManagement
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Product Management"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Commercial Configurator (AHT)"
.Style = msoButtonIconAndCaption
.FaceId = 82 'großes C
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "GE2306_AHT_Commercial_Configurator_2010-V4.xls"
.TooltipText = "L:\Company\Produkte\Artema_Hybrid\Commercial_Configurator\GE2306_AHT_Commercial_Configurator_2010-V4.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Shipped Order Details - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_SOD"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Serial Number List - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_SNL"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Format: Jahr-&Monat (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonth"
.State = msoButtonUp
.FaceId = 372 'Spalte mit Pfeil nach unten"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Status formatieren"
.Style = msoButtonIconAndCaption
.OnAction = "Format_Status"
.State = msoButtonUp
.FaceId = 352 'rote Lampe
.BeginGroup = False
End With
'
'Quality Management
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Quality"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Accounts"
.Style = msoButtonIconAndCaption
.FaceId = 80 'großes A
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "official oganization site"
.TooltipText = "L:\QM\Hypercom Chart of Accounts 3-31-10.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "IRIS-Codes (www.iriscode.org)"
.Style = msoButtonIconAndCaption
.FaceId = 82 'großes C
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "official oganization site"
.TooltipText = "http://www.iriscode.org/IrisCode.exe?Sid=.20110605230956656&action=file&name=pdf/EN_IRIS_03.12.22.pdf"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "PPM-Performance (WN)"
.Style = msoButtonIconAndCaption
.FaceId = 95 'großes P
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "monatliche Trendbetrachtung WN"
'.TooltipText = "X:\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\PPM-Performance.xls"
'.TooltipText = "\\bhelxfile2\xfer\"
.TooltipText = "\\bhelxfile2\xfer\transfer_enh\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\PPM-Performance.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Warenrückläufer - Wincor Nixdorf (WN)"
.Style = msoButtonIconAndCaption
.FaceId = 102 'großes W
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "monatliche Trendbetrachtung WN"
'.TooltipText = "X:\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\WR_Übersicht.xls"
.TooltipText = "\\bhelxfile2\xfer\transfer_enh\Transfer_Thales-EZH\EPP_Wincor-Nixdorf\WR_Übersicht.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Amdocs report - IRIS Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "AmdocsReports_IRIS_Pivot_WN"
.State = msoButtonUp
.FaceId = 7
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Status Quo - QM - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RSQ_QM"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analyse KEBA..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code_KEBA"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analyse WN..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code_WN"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: S/W Load Date (based on HSM_LIFELINE DB)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_SwLoadDate"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: 1st Shipped (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_1stShipped"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: HGN (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_HGN_Sub"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Item Revision (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_Rev"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Datecode (based on DIN EN 60062)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_Datecode"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: EMS Partner ID (based on Serial Number)"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Add_Column_EMS"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Pivot Chart formatting..."
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Format_PivotChart"
.State = msoButtonUp
.FaceId = 17 'Chart Symbol
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Fault Tree - Group ID Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Mapping_FaultTree"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Formel: HGN (8-stellig)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_HGN"
.State = msoButtonUp
.FaceId = 26 'Formelsymbol "Wurzel"
End With
'
'SalesOrderProcessing
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "&Sales Order Processing"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Open Orders Snapshot - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - On Hand Quantity - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_OHQ"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
'
'Service&Repair
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlPopup)
With CB_UApp
.Caption = "Service && &Repair"
.FaceId = 97 'großes R !!!! will not work here
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Anleitung - Grt Oracle Repair Tool (GORT)"
.Style = msoButtonIconAndCaption
.FaceId = 80 'großes A
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "Anleitung - Grt Oracle Repair Tool (GORT)"
.TooltipText = "L:\KV\KVR\GORT\GORT_V2.doc"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "IRIS-Codes (www.iriscode.org)"
.Style = msoButtonIconAndCaption
.FaceId = 82 'großes C
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "official oganization site"
.TooltipText = "http://www.iriscode.org/IrisCode.exe?Sid=.20110605230956656&action=file&name=pdf/EN_IRIS_03.12.22.pdf"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Übersicht &Wartungsstufen (Repair Level)"
.Style = msoButtonIconAndCaption
.FaceId = 102 'großes W
.HyperlinkType = msoCommandBarButtonHyperlinkOpen
.TooltipText = "Übersicht Wartungsstufen (Repair Level)"
.TooltipText = "L:\KV\KVR\_Übersicht Wartungsstufen\Repair Level - CrossReference.xls"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Status Quo - Service Provider"
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RSQ_SP"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Status Quo - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RSQ"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Fault Code - Pivot..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RFC"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - Repair Fault Code - Revenue..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Pivot_RFC_Revenue"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "&Cognos report - IRIS-Code Analyse..."
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_IRIS_Code"
.State = msoButtonUp
.FaceId = 6
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Repair &Level - Code Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Mapping_RepairLevel"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Repair Record &Type - Code Mapping"
.Style = msoButtonIconAndCaption
.OnAction = "Modul_Pivot.Mapping_RepairRecordType"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
.BeginGroup = False
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Serial Number - Marking uniqueless"
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Add_MarkingUniquelessSerialNumbers"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Add: Repair Orders - Marking uniqueless"
.Style = msoButtonIconAndCaption
.OnAction = "CognosReports_Add_MarkingUniquelessRepairOrders"
.State = msoButtonUp
.FaceId = 249 'Fragezeichen mit Spaltensymbol"
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Format: Jahr-&Monat (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonth"
.State = msoButtonUp
.FaceId = 372 'Spalte mit Pfeil nach unten"
.BeginGroup = True
End With
Set CB_Upopup = CB_UApp.Controls.Add(Type:=msoControlButton)
With CB_Upopup
.Caption = "Format: Jahr-Monat-&Tag (date type)"
.Style = msoButtonIconAndCaption
.OnAction = "Formel_YearMonthDay"
.State = msoButtonUp
.FaceId = 372 'Spalte mit Pfeil nach unten"
End With
'
'Standardmenü unten
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = "VeriFone &Logo"
.Style = msoButtonIconAndCaption
.OnAction = "Insert_VeriFoneLogo"
.State = msoButtonUp
.FaceId = 6376 'ABC Symbol
.BeginGroup = True
End With
'
'Ausgabestand
Set CB_UApp = CB_App.Controls.Add(Type:=msoControlButton)
With CB_UApp
.Caption = csPrivateMenuTitle & ".xla Version: " & Last_Modified
.TooltipText = Last_Modified
.Style = msoButtonIconAndCaption
.OnAction = Null
.FaceId = 0 'KEIN Symbol
.Enabled = False
.BeginGroup = True
End With
'Resourcen freigeben
Set CB_App = Nothing
Set CB_UApp = Nothing
Set CB_Upopup = Nothing
End If
End Sub
'2011-01-16
Sub Add_Dokumenteigenschaften_Hypercom()
Dim sComment As String: sComment = "Usage of 'Gries.xla' " & Last_Modified
Call Modul_Pivot.Add_AuthorInfo(sComment)
Application.Dialogs(xlDialogProperties).Show
End Sub
''''2011-01-16
'''Function Mapping_User_to_Username() As String
''' Mapping_User_to_Username = "" 'default
''' Dim strUserName As String: strUserName = GetUserLoginName()
''' Dim cUser As New Collection
''' 'Quality
''' cUser.Add "Michael Gries", "mgries" 'it's me
''' cUser.Add "Anne-Kathrin Raschke", "araschke" 'Anne-Kathrin Raschke
''' 'Supply Chain
''' cUser.Add "Bernd Poroffscheck", "bporoffsche" 'Improvement Engineer
''' cUser.Add "Marco Müller", "mmueller" '
''' 'Service&Repair
''' cUser.Add "Georg Niemann", "gniemann" 'Head of Service&Repair
''' cUser.Add "Falk Stolle", "fstolle" 'Project Leader
''' cUser.Add "Michael Blasl", "mblasl" 'Manager
''' cUser.Add "Jennifer Henningsen", "jhenningsen" 'Apprentice
''' cUser.Add "Nathalie Dunst", "ndunst" 'vormals Schwemmlein
''' 'SOP
''' cUser.Add "Peter Kuhn", "pkuhn" 'Peter Kuhn
''' 'PM
''' cUser.Add "Horst Bernshausen", "hbernshause" 'Product Manager
''' cUser.Add "Peter Florack", "pflorack" 'Technical Key Account
''' 'GPS
''' cUser.Add "Tom Detras", "TDetras" 'Head of GPS
''' cUser.Add "Ralene Yesenski", "RYesenski" 'nice lady
''' On Error Resume Next
''' Mapping_User_to_Username = cUser(strUserName)
'''End Function
'2011-11-21
Function Mapping_User_to_Username() As String
Mapping_User_to_Username = "" 'default
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
'Quality
cUser.Add "Michael Gries", "MichaelG12" 'it's me
cUser.Add "Anne-Kathrin Raschke", "araschke" 'Wareneingang
cUser.Add "Reinhold Pfeffer", "ReinholdP1" 'Lokales Qualitätsmanagement
cUser.Add "Norbert Köhler", "NorbertK1" 'Lokales Qualitätsmanagement
'Supply Chain
cUser.Add "Bernd Poroffscheck", "bporoffsche" 'Improvement Engineer
cUser.Add "Marco Müller", "mmueller" '
'Service&Repair
cUser.Add "Georg Niemann", "gniemann" 'Head of Service&Repair
cUser.Add "Falk Stolle", "fstolle" 'Project Leader
cUser.Add "Michael Blasl", "mblasl" 'Manager
'SOP
cUser.Add "Peter Kuhn", "pkuhn" 'Peter Kuhn
'PM
cUser.Add "Horst Bernshausen", "hbernshause" 'Product Manager
cUser.Add "Peter Florack", "pflorack" 'Technical Key Account
On Error Resume Next
Mapping_User_to_Username = cUser(strUserName)
End Function
''''2011-01-16
'''Function Mapping_User_to_Manager() As String
''' Mapping_User_to_Manager = "" 'default
''' Dim strUserName As String: strUserName = GetUserLoginName()
''' Dim cUser As New Collection
''' 'Quality
''' cUser.Add "TK Cheung", "mgries"
''' cUser.Add "Michael Gries", "araschke" 'Anne-Kathrin Raschke
''' 'Supply Chain
''' cUser.Add "Michael Gries", "bporoffsche" 'Bernd Poroffscheck
''' cUser.Add "Michael Gries", "mmueller" 'Marco Müller
''' 'Service&Repair
''' cUser.Add "Benno Rach", "gniemann" 'Georg Niemann
''' cUser.Add "Georg Niemann", "fstolle" 'Falk Stolle
''' cUser.Add "Georg Niemann", "mblasl" 'Michael Blasl
''' cUser.Add "Georg Niemann", "jhenningsen" 'Jennifer Hennigsen
''' 'SOP
''' cUser.Add "Benno Rach", "pkuhn" 'Peter Kuhn
''' 'PM
''' cUser.Add "Norbert Albrecht", "hbernshause" 'Horst Bernshausen
''' cUser.Add "Norbert Albrecht", "pflorack" 'Peter Florack
''' 'GPS
''' cUser.Add "TK Cheung", "TDetras" 'Tom Detras
''' cUser.Add "Tom Detras", "RYesenski" 'Rai Yesenski
''' On Error Resume Next
''' Mapping_User_to_Manager = cUser(strUserName)
'''End Function
'2011-11-21
Function Mapping_User_to_Manager() As String
Mapping_User_to_Manager = "" 'default
Dim strUserName As String: strUserName = GetUserLoginName()
Dim cUser As New Collection
'Quality
cUser.Add "Don Perkins", "MichaelG12"
cUser.Add "Michael Gries", "T_AnneR1" 'Anne-Kathrin Raschke
cUser.Add "Norbert Albrecht", "ReinholdP1" 'Lokales Qualitätsmanagement
cUser.Add "Reinhold Pfeffer", "NorbertK1" 'Lokales Qualitätsmanagement
'Supply Chain
cUser.Add "Ralf Seger", "BerndP1" 'Bernd Poroffscheck
cUser.Add "Ralf Seger", "MarcoM1" 'Marco Müller
'Service&Repair
cUser.Add "Georg Niemann", "FalkS1" 'Falk Stolle
cUser.Add "Georg Niemann", "MichaelB18" 'Michael Blasl
'SOP
cUser.Add "Markus Hoevekamp", "pkuhn" 'Peter Kuhn
'PM
cUser.Add "Norbert Albrecht", "hbernshause" 'Horst Bernshausen
cUser.Add "Norbert Albrecht", "pflorack" 'Peter Florack
On Error Resume Next
Mapping_User_to_Manager = cUser(strUserName)
End Function
Attribute VB_Name = "Modul_ADO"
'(c)2011, Michael Gries, 2011-06-12
'Letzte Änderung: 2011-06-13
'
'SQL statements
'SELECT [DISTINCT] Auswahlliste [AS Spaltenalias]
'FROM Quelle [AS Tabellenalias]
'[WHERE Where-Klausel]
'[GROUP BY (Group-by-Attribut)+
'[HAVING Having-Klausel]]
'[ORDER BY (Sortierungsattribut [ASC|DESC])+];
Const csMSACCESS97 = "Provider=Microsoft.Jet.oledb.4.0"
'2011-06-13
Sub ADO_Get_SN_Function_test()
Dim s1stShipped As String
s1stShipped = ADO_Get_SN("CNCCB-1026734688") 'EPP V6
s1stShipped = ADO_Get_SN("TR 1024209030") 'EPP V5
End Sub
'2011-06-13
Sub ADO_Get_HGN_Function_test()
Dim sLoadDate As String
sLoadDate = ADO_Get_HGN("62343567")
sLoadDate = ADO_Get_HGN("62360779")
End Sub
'2011-06-15
Sub ADO_Get_Rev_Function_test()
Dim sItemRev As String
sItemRev = ADO_Get_Rev("medCompact", "210315062367188") '=02
sItemRev = ADO_Get_Rev("medCompact", "210315062815770") '=04
End Sub
'2011-06-15
Function ADO_Get_Rev(sFROM As String, sSN As String)
ADO_Get_Rev = "#NV" 'Default
Const csKeyWord = "data source="
Const csFileOffline = "D:\SNL\SNL.mdb"
Const csFileNetwork = "L:\QM\SNL\SNL.mdb"
'Const csWHERE = """SERIAL #""" 'nach SQL teilweise möglich aber nicht MS ACCESS
'Const csWHERE = """SERIAL NO""" 'nach SQL teilweise möglich aber nicht MS ACCESS
Const csWHERE = "SerialNo" ' 'SERIAL #' von Cognos muss in MS ACCESS geändert werden
Dim ADOC As New ADODB.Connection
Dim DBS As New ADODB.Recordset
Dim cmd As ADODB.Command
On Error GoTo Fehlerbehandlung
Dim sFile As String
If Modul_WSH.CheckDriveExists("L") Then
sFile = csFileNetwork
Else
sFile = csFileOffline
End If
Dim sSource As String: sSource = csKeyWord & sFile
ADOC.Open csMSACCESS97 & ";" & sSource & ";"
DBS.Open sFROM, ADOC, adOpenKeyset, adLockOptimistic
Dim sQuery As String
sQuery = "select * from " & sFROM & " where " & csWHERE & " like('" & sSN & "')"
Set cmd = New ADODB.Command
cmd.CommandText = sQuery
cmd.ActiveConnection = ADOC
Set DBS = cmd.Execute
Do While Not DBS.EOF
ADO_Get_Rev = DBS![Item Rev] ' letzten Eintrag übernehmen
DBS.MoveNext
Loop
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
Exit Function
Fehlerbehandlung:
MsgBox "Es ist ein Fehler aufgetreten!" _
& Chr(13) & Err.Description
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
ADO_Get_Rev = "#ERR"
End Function
'2011-06-13
Function ADO_Get_HGN(sFROM As String, sHGN As String, bFirstOccurance As Boolean)
ADO_Get_HGN = "#NV" 'Default
'Const csSource = "data source=D:\LDB\LDB.mdb"
Const csKeyWord = "data source="
Const csFileOffline = "D:\LDB\LDB.mdb"
Const csFileNetwork = "L:\QM\LDB\LDB.mdb"
'Const csFROM = "LDB"
Const csWHERE = "SerienNr"
Dim ADOC As New ADODB.Connection
Dim DBS As New ADODB.Recordset
Dim cmd As ADODB.Command
On Error GoTo Fehlerbehandlung
Dim sFile As String
If Modul_WSH.CheckDriveExists("L") Then
sFile = csFileNetwork
Else
sFile = csFileOffline
End If
Dim sSource As String: sSource = csKeyWord & sFile
ADOC.Open csMSACCESS97 & ";" & sSource & ";"
DBS.Open sFROM, ADOC, adOpenKeyset, adLockOptimistic
Dim sQuery As String
sQuery = "select * from " & sFROM & " where " & csWHERE & " like('" & sHGN & "')"
Set cmd = New ADODB.Command
cmd.CommandText = sQuery
cmd.ActiveConnection = ADOC
Set DBS = cmd.Execute
Do While Not DBS.EOF
ADO_Get_HGN = DBS!LadeZeit 'Eintrag übernehmen
DBS.MoveNext 'nächsten Eintrag auswählen
If bFirstOccurance Then 'nur ersten Eintrag übernehmen
Exit Do
End If
Loop
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
Exit Function
Fehlerbehandlung:
MsgBox "Es ist ein Fehler aufgetreten!" _
& Chr(13) & Err.Description
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
ADO_Get_HGN = "#NV"
End Function
'2011-06-13
Function ADO_Get_SN(sFROM As String, sSN As String)
ADO_Get_SN = "#NV" 'Default
'Const csSource = "data source=D:\SNL\SNL.mdb"
Const csKeyWord = "data source="
Const csFileOffline = "D:\SNL\SNL.mdb"
Const csFileNetwork = "L:\QM\SNL\SNL.mdb"
'Const csFROM = "EPP"
'Const csWHERE = "SERIAL_NO"
Const csWHERE = "SerialNo" ' 'SERIAL #' von Cognos muss in MS ACCESS geändert werden
Dim ADOC As New ADODB.Connection
Dim DBS As New ADODB.Recordset
Dim cmd As ADODB.Command
On Error GoTo Fehlerbehandlung
Dim sFile As String
If Modul_WSH.CheckDriveExists("L") Then
sFile = csFileNetwork
Else
sFile = csFileOffline
End If
Dim sSource As String: sSource = csKeyWord & sFile
ADOC.Open csMSACCESS97 & ";" & sSource & ";"
DBS.Open sFROM, ADOC, adOpenKeyset, adLockOptimistic
Dim sQuery As String
sQuery = "select * from " & sFROM & " where " & csWHERE & " like('" & sSN & "')"
Set cmd = New ADODB.Command
cmd.CommandText = sQuery
cmd.ActiveConnection = ADOC
Set DBS = cmd.Execute
Do While Not DBS.EOF
ADO_Get_SN = DBS!DeliveryDate ' letzten Eintrag übernehmen
DBS.MoveNext
Loop
Exit Function
Fehlerbehandlung:
MsgBox "Es ist ein Fehler aufgetreten!" _
& Chr(13) & Err.Description
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
ADO_Get_SN = "#ERR"
End Function
'2011-06-12
Sub ADO_Get_HGN_Test()
Const csHGN = "62343567"
Dim ADOC As New ADODB.Connection
Dim DBS As New ADODB.Recordset
Dim cmd As ADODB.Command
On Error GoTo Fehlerbehandlung
ADOC.Open csMSACCESS97 & ";" & _
"data source=D:\LDB\medCompact.mdb;"
DBS.Open "LDB", ADOC, adOpenKeyset, _
adLockOptimistic
Set cmd = New ADODB.Command
cmd.CommandText = "select * from LDB where HGN like('" & csHGN & "')"
cmd.ActiveConnection = ADOC
Set DBS = cmd.Execute
On Error Resume Next
Sheets("HGN").Delete
On Error GoTo Fehlerbehandlung
Sheets.Add
ActiveSheet.Name = "HGN"
Range("A2").Select
Do While Not DBS.EOF
ActiveCell.offset(0, 0).Value = DBS!ID
ActiveCell.offset(0, 1).Value = DBS!HGN
ActiveCell.offset(0, 2).Value = DBS!LOAD_DATE
ActiveCell.offset(0, 3).Value = DBS!ITEM_NUMBER
DBS.MoveNext
ActiveCell.offset(1, 0).Select
Loop
Columns("A:D").AutoFit
DBS.Close
ADOC.Close
Set DBS = Nothing
Set ADOC = Nothing
Set cmd = Nothing
Exit Sub
Fehlerbehandlung:
MsgBox "Es ist ein Fehler aufgetreten!" _
& Chr(13) & Err.Description
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
End Sub
'2011-06-12
Sub DatenübernahmeNachExcel()
' aus Bernd Held, Excel VBA in 21 Tagen
' unbedingt Verweis auf ActiveX Data Objects setzen
' Microsoft ActiveX Data Objects 2.8 Library
Dim ADOC As New ADODB.Connection
Dim DBS As New ADODB.Recordset
Dim cmd As ADODB.Command
On Error GoTo Fehlerbehandlung
ADOC.Open "Provider=Microsoft.Jet.oledb.4.0;" & _
"data source=D:\LDB\medCompact.mdb;"
DBS.Open "LDB", ADOC, adOpenKeyset, _
adLockOptimistic
Set cmd = New ADODB.Command
cmd.CommandText = "Select * from LDB"
cmd.ActiveConnection = ADOC
Set DBS = cmd.Execute
Sheets("Import").Activate
Range("A2").Select
Do While Not DBS.EOF
ActiveCell.Value = DBS!ID
ActiveCell.offset(0, 1).Value = DBS!HGN
ActiveCell.offset(0, 2).Value = DBS!LOAD_DATE
ActiveCell.offset(0, 3).Value = DBS!ITEM_NUMBER
' If DBS!Bezahlt = True Then
' ActiveCell.offset(0, 9).value = "ja"
' Else
' ActiveCell.offset(0, 9).value = "Nein"
' End If
DBS.MoveNext
ActiveCell.offset(1, 0).Select
Loop
Columns("A:C").AutoFit
DBS.Close
ADOC.Close
Set DBS = Nothing
Set ADOC = Nothing
Set cmd = Nothing
Exit Sub
Fehlerbehandlung:
MsgBox "Es ist ein Fehler aufgetreten!" _
& Chr(13) & Err.Description
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
End Sub
Attribute VB_Name = "Modul_Akustik"
Option Explicit
Option Private Module
'(C) 2005, Michael Gries
Const csHomeUser As String = "Michael"
Const csFilename As String = "Akustikmodul.xls"
Const csHomeServer As String = "C:\Dokumente und Einstellungen\Michael\"
Const csHomePath As String = "Eigene Dateien\"
Const csOfficeServer As String = "\\bber021a\did82006\"
Const csOfficePath As String = "KP\Pruef_Labor_Daten\Akustik\"
Public Const csMessageAkustik As String = "net send uidf9246 Akustikmodul"
Sub Akustikmodul()
On Error GoTo Abbruch
'Application.CommandBars(1).Controls("Applikation").Caption = "Test"
Dim CB_App As CommandBarControl
Dim CB_UApp As CommandBarControl
Set CB_App = Application.CommandBars(1).Controls("Applikation")
Set CB_UApp = CB_App.Controls.Add _
(Type:=msoControlButton, Before:=2)
With CB_UApp
.Caption = "&Akustikmodul starten"
.Style = msoButtonIconAndCaption
.OnAction = "AkustikmodulLaden"
.State = msoButtonUp
.FaceId = 68 'Lautsprechersymbol
.BeginGroup = True
End With
Exit Sub
Abbruch:
'Wenn Applikations Menü nicht erlaubt (aktiviert)
End Sub
Private Sub AkustikmodulLaden()
Dim sServer As String: Dim sPath As String: Dim sFile As String
Dim strUserName As String
strUserName = GetUserLoginName()
If strUserName = csHomeUser Then
sServer = csHomeServer: sPath = csHomePath: sFile = csFilename
Else
sServer = csOfficeServer: sPath = csOfficePath: sFile = csFilename
End If
Dim iTaskID: iTaskID = Shell(csMessageAkustik): Debug.Print iTaskID
Workbooks.Open Filename:=sServer & sPath & sFile 'Datei Öffnen
End Sub
Attribute VB_Name = "Modul_Ankerdaten"
Option Explicit
'(c)2005, Michael Gries
Public iPolzahl As Integer
Sub DateiLaden_Anker()
' Konstanten
Const DateiFilterTyp As String = "Anker-Rohdaten (AF*.),AF*."
Const DialogÖffnenTitle As String = "Öffnen: Rohdaten Anker"
Const strAF As String = "AF": Const strAL As String = "AL"
Const strAnkerdateiMerkmal As String = "&H8884" ' die ersten zwei Byte jeder Ankerdatei
Const strAnkerdateiEnde As String = "&HFFFF" ' die letzten zwei Byte jeder Ankerdatei
Dim WorkbookSaveAsName As String
Dim i As Integer, j As Integer
Dim l As Long
Dim lng As Long
Dim Mappen As Variant
Dim iMappen As Long
Dim rCell As Range
Dim sText As String '* 10000
Dim sInputLines(0 To 7) As String
Dim sTextArrayX() As String
Dim sAnkerdatenX() As String
Dim iAnzahlDatensätze As Integer
Dim lText As Long
Dim sOtherCharX As String
Dim sOtherCharXX As String
Dim sTmp As String
Dim sLeft As String
Dim sRight As String
Dim sDateiAnfangID As String
Dim sDateiEndeID As String
Dim strScrollAreaRange As String
Application.DisplayStatusBar = False
sOtherCharX = VBA.Chr(CByte(&H3)) & " " ' = '03 20' als Datensatztrenner
sOtherCharXX = VBA.Chr(CByte(&H7)) & " " ' = `07 20' als Einzelwerttrenner eines Ankerdatensatzes
sDateiAnfangID = VBA.Chr(CByte(&H88)) & VBA.Chr(CByte(&H84)) ' = '88 84' markiert Dateianfang
sDateiEndeID = VBA.Chr(CByte(&HFF)) & VBA.Chr(CByte(&HFF)) ' = 'FF FF' markiert Dateiende
iMappen = 0
Mappen = Application.GetOpenFilename(DateiFilterTyp, FilterIndex:=0, Title:=DialogÖffnenTitle, MultiSelect:=True)
If IsArray(Mappen) Then
For iMappen = LBound(Mappen) To UBound(Mappen)
'Ggf. Meldung bei OpenText Prozedur unterdrücken, falls Format nicht erkannt wird
Application.DisplayAlerts = False
Workbooks.OpenText Mappen(iMappen), DataType:=xlDelimited
Application.DisplayAlerts = True
'Bestimmung Merkmale zum Auftrennen des Strings an definierten Stellen
'(Ermittlung z.B. mit Programm WINHEX oder ähnlichem Hex-Editor)
'
Range("A1:A6").Select 'Annahme: max. 6 Teilstrings
'durch &h0D (CR) können die Rohdaten auf mehrere Zellen in Spalte A verteilt sein.
'diese zunächst in einem Textarray zusammenfassen ...
i = 0
For Each rCell In Selection
sInputLines(i) = rCell.Value
i = i + 1
Next rCell
' ... und anschliesend zu einem Textstring zusammenführen
sText = Join(sInputLines(), "")
lText = Len(sText)
sLeft = VBA.Left(sText, 2): sRight = VBA.Right(sText, 2)
Debug.Print lText; sText; vbCr; sLeft; vbCr; sRight
'prüfen anhand Dateimerkmalen, ob es sich um eine Ankerdatei handelt
If VBA.Left(sText, 2) = sDateiAnfangID _
And VBA.Right(sText, 2) = sDateiEndeID _
Then
'Zunächst DateiEnde Markierung abschneiden (2 Byte)
sText = VBA.Left(sText, Len(sText) - 2)
'Datensatz Umbruch vereinheitlichen
sText = Replace(sText, VBA.Chr(CByte(&H2)), VBA.Chr(CByte(&H3)))
sTextArrayX = Split(sText, sOtherCharX)
For i = 1 To UBound(sTextArrayX) 'Anzahl Datensätze
sTmp = sTextArrayX(i)
sTmp = Replace(sTmp, VBA.Chr(CByte(&H4)), VBA.Chr(CByte(&H7)))
sTmp = Replace(sTmp, VBA.Chr(CByte(&H5)), VBA.Chr(CByte(&H7)))
sTmp = Replace(sTmp, VBA.Chr(CByte(&H6)), VBA.Chr(CByte(&H7)))
'Anker Datensatz zerlegen in Einzelwerte
sAnkerdatenX = Split(sTmp, sOtherCharXX)
For j = 0 To UBound(sAnkerdatenX) 'Anzahl Ankerwerte
sTmp = WorksheetFunction.Clean(sAnkerdatenX(j)) 'nicht Druckbare Zeichen entfernen
sTmp = WorksheetFunction.Trim(sTmp) 'restliche Leerzeichen entfernen
' Debug.Print sTmp
Cells(i + 1, j + 1) = sTmp
Next j
Next i
'Datenkopf bearbeiten
'Zellinhalte:
'Zelle A1=DateiAnfang Merkmal
'Zelle A2=Anfangswert Datensatz i.d.R 1
'Zelle A3=Kommentar beginnend mit Anzahl Datensätze (+1) und Ax-Nummer
'Zelle A4=Zahl für x-teiligen Anker (Polzahl)
'
'Registernamen in Zelle A1
Cells(1, 1) = ActiveSheet.Name
'Polzahl sichern und zelle löschen
iPolzahl = Cells(4, 1).Value: Debug.Print iPolzahl & "-teiliger Anker"
'Cells(2, 1).NumberFormat = "@""-teiliger Anker"""
Cells(2, 1) = iPolzahl & "-teiliger Anker": Cells(4, 1) = ""
'AF_ oder AL_ Nummer aus Text extrahieren
sTmp = Cells(3, 1).Value
lng = InStr(1, sTmp, ActiveSheet.Name)
If lng Then
sTmp = VBA.Right(sTmp, Len(sTmp) - Len(ActiveSheet.Name))
Cells(3, 1) = VBA.Right(sTmp, Len(sTmp) - InStr(1, sTmp, " "))
Debug.Print Cells(3, 1)
End If
Else
MsgBox "Keine Ankerdatei Merkmale vorhanden !!!" & vbCr & vbCr & sText
End If
'Ankerdaten formatieren
Call Ankerdatei_Formatieren
' Dokument Eigenschaften
With ActiveWorkbook ' or for add-ins use "ThisWorkbook"
.BuiltinDocumentProperties("Title").Value = ActiveSheet.Name
.BuiltinDocumentProperties("Subject").Value = "Ankerdaten Auswertung"
.BuiltinDocumentProperties("Company").Value = "Siemens VDO"
.BuiltinDocumentProperties("Manager").Value = "Bernd Wehrum"
.BuiltinDocumentProperties("Author").Value = "created by macro (Gries)"
.BuiltinDocumentProperties("Last Author").Value = "created by macro (Gries)"
.BuiltinDocumentProperties("Application Name").Value = "Auswertung"
.BuiltinDocumentProperties("Category").Value = "Motoren"
.BuiltinDocumentProperties("Comments").Value = "None"
.BuiltinDocumentProperties("Keywords").Value = "Anker, Rotor"
End With
' Arbeitsmappe speichern
' vorher Dateiname ermitteln; -4 heißt Endung abschneiden; hier jedoch Datei ohne Endung
WorkbookSaveAsName = VBA.Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4 + 4) & ".xls"
ActiveWorkbook.SaveAs Filename:=WorkbookSaveAsName, FileFormat:=xlNormal
' Diese Eigenschaften können erst nach Wandlung (d.h. Speichern)
' von Textdatei in Exceldatei erstellt werden.
'With ActiveWorkbook
' .CustomDocumentProperties.Add Name:="Makro Ansprechpartner", _
' LinkToContent:=False, Type:=msoPropertyTypeString, Value:="Gries"
' .CustomDocumentProperties.Add Name:="Macro Version", _
' LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=2
' .CustomDocumentProperties.Add Name:="Abteilung", _
' LinkToContent:=False, Type:=msoPropertyTypeString, Value:="FS RD BBE D"
'End With
'
'With ActiveSheet
' .CustomProperties.Add Name:="Ansprechpartner", Value:="M. Gries"
' .CustomProperties.Add Name:="Telefon", Value:="-770"
'End With
' erneutes Speichern
'ActiveWorkbook.SaveAs Filename:=WorkbookSaveAsName, FileFormat:=xlNormal
With Application
.DisplayStatusBar = True
.StatusBar = "Daten wurden als Excel-Datei: " & WorkbookSaveAsName & " gesichert"
End With
l = Timer
Do While Timer < l + 5
DoEvents
Loop
Application.StatusBar = False
'alle Mappen bearbeiten
Next iMappen
Else
MsgBox "Es wurde keine Datei ausgewählt! "
Exit Sub
End If
End Sub
Private Sub Ankerdatei_Formatieren()
Dim i As Integer
'Spalten formatieren
With Columns("B:N")
.NumberFormat = "0"
.ColumnWidth = 8
End With
'Gesamtwiderstandsspalte fett
Columns(iPolzahl + 2).Font.Bold = True
'Kopfzeile hinzufügen
Rows(5).Insert
With Range(Cells(5, 1), Cells(5, iPolzahl + 2))
.Font.Bold = True
.Interior.ColorIndex = 15
End With
Cells(5, 1) = "Part": Cells(5, iPolzahl + 2) = "Rges"
For i = 1 To iPolzahl
Cells(5, i + 1) = "R" & i
Next i
Range("A5").Activate
ActiveCell.CurrentRegion.Select
Selection.HorizontalAlignment = xlCenter
With Selection.Borders
.LineStyle = xlContinuous
End With
' Fenster Einstellungen
With ActiveWindow
.SplitRow = 5
.SplitColumn = 0
.FreezePanes = True
.Zoom = 100
End With
With ActiveSheet.Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
.SummaryColumn = xlLeft
.ShowLevels RowLevels:=1, ColumnLevels:=1
End With
'strScrollAreaRange = Selection.Address
'ActiveSheet.ScrollArea = strScrollAreaRange
''ActiveCell.CurrentRegion.Select 'hier identisch mit UsedRange
'
'With Application
' .CutCopyMode = False 'keine Zellmarkierung
' .ActiveWindow.DisplayGridlines = False
'End With
End Sub
Attribute VB_Name = "Modul_API_functions"
Option Explicit
' Datentypen
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Service Pack
End Type
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Declare Function GetVersionEx1 Lib "kernel32.dll" Alias _
"GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Function ShellAbout Lib "shell32.dll" _
Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, _
ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function SystemBeep Lib "kernel32.dll" _
Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Function OpenDeviceManager Lib "devmgr.dll" _
Alias "DeviceManager_ExecuteA" (ByVal hWndParent As Long, _
ByVal hInst As Long, ByVal lpMachineName As String, _
ByVal nCmdShow As Integer) As Boolean
Private Declare Function sndPlaySound32 Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
'
' Geräte Manager von Command-Box aus starten:
' Rundll32.exe devmgr.dll DeviceManager_ExecuteA /DeviceID root\system\0000
' Rundll32.exe devmgr.dll DeviceManager_RunDLL /DeviceID root\system\0000
'
'End Deklarationen
Sub OCX_Install()
Shell "regsvr32 c:\windows\system32\mscomct2.ocx" '(DllRegisterServer)
End Sub
Public Function GetOSVersion() As Integer
Dim OsVersInfo As OSVERSIONINFO
If GetVersionEx1(OsVersInfo) = 0 Then
MsgBox "Fehler im API-Aufruf: GetVersionEx1"
Else
GetOSVersion = OsVersInfo.dwPlatformId
End If
End Function
Sub Test_OSVersion()
Debug.Print GetOSVersion
End Sub
Sub ApplikationGeräteManager()
' Const sDeviceID As String = "/DeviceID"
' Const sPath As String = "root\system\0000"
Const lpMachineName As String = "GA"
Const nCmdShow As Integer = 1
Dim bResult As Boolean
bResult = OpenDeviceManager(1, 1, lpMachineName, nCmdShow)
Debug.Print bResult
End Sub
Sub Show_Info()
Dim hwnd As Long
Const hIcon As Long = 5 'Exclamation Mark
Const szApp As String = "Akustikmodul"
Const szOtherStuffLine1 As String = "Michael Gries, SV P FS RD BBE D"
Const szOtherStuffLine2 As String = "http://www.siemensvdo.de"
ShellAbout hwnd, szApp, " " & szOtherStuffLine1 _
& vbCrLf & " " & szOtherStuffLine2, hIcon
End Sub
Private Sub Get_LoginName()
Dim strUserName As String
strUserName = GetUserLoginName()
MsgBox "Windows login name: " & strUserName & " (" & Application.UserName & ")"
End Sub
Function GetUserLoginName() As String
Dim strTemp As String, strUserName As String
'Create buffers
strTemp = VBA.String(100, VBA.Chr$(0))
strUserName = VBA.String(100, VBA.Chr$(0))
'API function
GetUserName strUserName, 100
'strip the rest of the buffer
strUserName = VBA.Left$(strUserName, InStr(strUserName, VBA.Chr$(0)) - 1)
Debug.Print strUserName
GetUserLoginName = strUserName
End Function
Function GetEnvironUsername()
'den aktuellen Benutzer ermitteln (nur: NT, 2000, Xp)
Dim sUsername As String
sUsername = Environ("UserName")
'Debug.Print sUsername
'MsgBox "Benutzer: " & sUserName
GetEnvironUsername = sUsername
End Function
Function GetEnvironComputername() As String
GetEnvironComputername = VBA.Interaction.Environ("Computername")
End Function
Function GetEnvironUserprofile() As String
GetEnvironUserprofile = VBA.Interaction.Environ("Userprofile")
End Function
Function AddNetHoodLink(sfolder As String)
Dim sUserPath As String
sUserPath = GetEnvironUserprofile
Debug.Print sUserPath
End Function
Sub LinkTest()
AddNetHoodLink ("Test")
End Sub
Function SystemBeep_OK()
Const clKammerton_A As Long = 440 'Hz
Dim dwFreq1 As Long: Dim dwFreq2 As Long
dwFreq1 = clKammerton_A * 3
dwFreq2 = clKammerton_A * 2
'Doppelton kurz
SystemBeep dwFreq1, 200
SystemBeep 20000, 100 'nicht hörbar als Pause
SystemBeep dwFreq2, 200
End Function
Sub SoundStart()
Dim iCounter As Integer
Application.EnableCancelKey = xlErrorHandler
On Error GoTo ERRORHANDLER
For iCounter = 1 To 10
Call sndPlaySound32(Range("A1").Value, 1)
Application.Wait Now + TimeSerial(0, 0, 2)
Next iCounter
ERRORHANDLER:
End Sub
Public Function ScreenResolution()
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
ScreenResolution = GetSystemMetrics(SM_CXSCREEN) & _
"x" & GetSystemMetrics(SM_CYSCREEN)
Debug.Print "Bildschirmauflösung: "; ScreenResolution
End Function
Attribute VB_Name = "Modul_Diagramm"
'(c) 2006, Michael Gries
'Erstellung: 2006-01-14
'2006-01-17: Diagramm Q=f(U)
'2006-02-05: Diagramm Q=f(n)
'2006-12-17: Diagramm Q=f(p)
'2007-08-06: Histogramm-Daten
'2007-08-18: Histogramm-Diagramm
'Letzte Änderung: 2006-11-05
'
Option Explicit
Dim clsDiagramm As New Klasse_Diagramm 'Name des Klassenmoduls
'
Const DiaLeft As Integer = 0
Const DiaTop As Integer = 0
Const DiaWidth As Integer = 640 / 2 'geeignet für Display-Auflösung 1024x768
Const DiaHeight As Integer = 420 / 2
Public iY1AxesMaximumScale As Integer
Public iY2AxesMaximumScale As Integer
Dim intScaleDiaWidth As Integer, intScaleDiaHeight As Integer
'übernimmt die Konstanten DiaWidth/DiaHeight
'
'End Deklarationen
Function Get_Pumptype_Slope(sType As String) As Double
'liefert referenzierte Steigungen verschiedener Pumpen
'für das Q=f(n) Diagramm
'zur Bestimung der Pumpenstufenqualität
'Testdatei s. "!REF_Kennliniensteigung f(n).xls"
Dim colSlope As New Collection
colSlope.Add 0.047, "4.2" 'C-Muster (Basis: 17L6)
colSlope.Add 0.028, "4.42" 'Serie (Basis: 1001K7)
colSlope.Add 0.042, "4.6" 'Serie
colSlope.Add 0.054, "4.6eta" 'C-Muster (Basis: 1110L7)
colSlope.Add 0.057, "5.6" 't.b.d.
colSlope.Add 0.057, "5.7" 't.b.d.
colSlope.Add 0.071, "6.6" 'C-Muster (Basis: 897K7)
colSlope.Add 0.086, "8.0" 't.b.d.
colSlope.Add 0.029, "8.6" 'C-Muster (Basis: 606K6)
colSlope.Add 0.016, "11.0" 'C-Muster (Basis: 528K7)
Get_Pumptype_Slope = colSlope(sType)
Debug.Print "Gradient: "; colSlope(sType)
End Function
Sub Insert_Musterkopfzeile()
'2007-08-18
If Test_Dateimerkmale_Prüfstand("Typ:", "Kunde:", "Muster") Then
Application.ScreenUpdating = False
Dim lStartRow As Long: lStartRow = Find_Row("Muster", "A:A") + 1
Dim lNoOfRows As Long: lNoOfRows = Cells(lStartRow, 1).CurrentRegion.Rows.Count
Dim iNoOfCols As Long: iNoOfCols = Cells(lStartRow, 1).CurrentRegion.Columns.Count
Dim sMuster1 As String: Dim sMuster2 As String
Dim i As Long: i = lStartRow
Do
sMuster1 = Cells(i, 1): sMuster2 = Cells(i + 1, 1)
'Rows(i + 1).Select 'nur für Testzwecke
If sMuster1 <> sMuster2 And _
sMuster1 <> "Muster" And _
sMuster2 <> "Muster" _
Then
Rows(i + 1).Insert xlShiftUp
Cells(i + 1, 1).Value = "Muster"
Range(Cells(i + 1, 1), Cells(i + 1, iNoOfCols)).Interior.ColorIndex = 15 'hellgrau
i = i + 1
End If
i = i + 1
Loop Until sMuster2 = ""
End If
Application.ScreenUpdating = True
End Sub
Sub Histo_Diagramm()
Attribute Histo_Diagramm.VB_Description = "H"
Attribute Histo_Diagramm.VB_ProcData.VB_Invoke_Func = "H\n14"
'Erstellung: 2007-08-06
'Letzte Änderung:2007-08-06
If Test_Dateimerkmale_Prüfstand("Typ:", "Kunde:", "Muster") Then
If Not Diagramm_Histo Then GoTo Diagramm_Err
End If
Exit Sub
Diagramm_Err:
MsgBox "Diagramm Fehler in Prozedur 'Diagramm_Histo'"
End Sub
Sub Expand_Chart_Kontext()
Const csMenüName As String = "SVDO Diagramm"
Dim CB As CommandBarControl
'On Error Resume Next
Application.CommandBars("Chart") _
.Controls(csMenüName).Delete
Set CB = Application.CommandBars("Chart").Controls.Add _
(Type:=msoControlButton)
With CB
.Caption = csMenüName
.TooltipText = "Achsen mittels UMS oder STRG ändern"
.Style = msoButtonIconAndCaption
.OnAction = "Convert_ASC_Dateien"
.FaceId = 300 '300 Tabelle ohne Excel Symbol, 142 mit
.BeginGroup = True
End With
End Sub
Sub InitializeChart()
Set clsDiagramm.SVDO_Diagramm = _
ActiveSheet.ChartObjects(1).Chart
End Sub
Sub Q_n_Diagramm()
Attribute Q_n_Diagramm.VB_Description = "N"
Attribute Q_n_Diagramm.VB_ProcData.VB_Invoke_Func = "N\n14"
If Test_Dateimerkmale_Prüfstand("Typ:", "Kunde:", "Muster") Then
If Not Diagramm_XY_n Then GoTo Diagramm_Err
End If
Exit Sub
Diagramm_Err:
MsgBox "Diagramm Fehler"
End Sub
Sub QI_U_Diagramm()
Attribute QI_U_Diagramm.VB_Description = "U"
Attribute QI_U_Diagramm.VB_ProcData.VB_Invoke_Func = "U\n14"
If Test_Dateimerkmale_Prüfstand("Typ:", "Kunde:", "Muster") Then
If Not Diagramm_XY_U Then GoTo Diagramm_Err
End If
Exit Sub
Diagramm_Err:
MsgBox "Diagramm Fehler"
End Sub
Sub QI_p_Diagramm()
Attribute QI_p_Diagramm.VB_Description = "Diagramm Darstellung über Druck p"
Attribute QI_p_Diagramm.VB_ProcData.VB_Invoke_Func = "P\n14"
'2006-12-17
If Test_Dateimerkmale_Prüfstand("Typ:", "Kunde:", "Muster") Then
If Not Diagramm_XY_p Then GoTo Diagramm_Err
End If
Exit Sub
Diagramm_Err:
MsgBox "Diagramm Fehler"
End Sub
Function Diagramm_Histo() As Boolean
Const csHistogrammbereich As String = "M3:Q14"
Const csStartDataRange As String = "N3"
Dim sStartDiagramm As String
Dim bStatistik As Boolean
If Modul_Prüfstand.Test_Dateimerkmale_Prüfstand("Funktion (n)", "Mittelwert (1)", "Zähler (2)") Then
bStatistik = True
sStartDiagramm = "M2"
ActiveSheet.AutoFilterMode = False 'Autofilter zurücksetzen
Else
Call Insert_Statistik
bStatistik = True
End If
Range(csStartDataRange).Select
ThisWorkbook.Worksheets("Statistik").Range(csHistogrammbereich).Copy
ActiveSheet.Paste
Columns("M:Q").AutoFit
Diagramm_Histo = True
Const sDiagrammName As String = "Histo"
Const sDiagrammTitle As String = "Verteilung"
Const x_Header As String = "Klasse"
Const y_Header As String = "Verteilung"
ActiveSheet.Cells(1, 1).Activate
On Error Resume Next
ActiveSheet.ChartObjects(sDiagrammName).Delete 'falls vorhanden
Dim XY_Chart As ChartObject
Dim sChartTitle As String
Dim sPumpentyp As String: sPumpentyp = Range("B" & Find_Row("Typ:", "A:A")).Value
Dim lStartRow As Long: lStartRow = Find_Row("Funktion (n)", "A:A") + 1
Dim lStopRow As Long: lStopRow = 14
Dim sDatenbereich As String: sDatenbereich = Range(csStartDataRange).CurrentRegion.Address
'Default Diagrammgröße einstellen
intScaleDiaWidth = DiaWidth: intScaleDiaHeight = DiaHeight
'Skalierungswerte anhand des Maxiamalwertes der MAXIMUM-Zeile ermitteln
iY1AxesMaximumScale = WorksheetFunction.RoundUp(Range("F4"), 0) 'Ganzzahl
Application.ScreenUpdating = False
Set XY_Chart = ActiveSheet.ChartObjects.Add(DiaLeft, DiaTop, DiaWidth, DiaHeight)
XY_Chart.Name = sDiagrammName
sChartTitle = sDiagrammTitle
Dim xCol As String: xCol = Find_Column(x_Header, sDatenbereich)
Dim S1Col As String: S1Col = Find_Column(y_Header, sDatenbereich)
Dim xHeaderRange As String: xHeaderRange = Find_Cell(x_Header, sDatenbereich)
Dim S1HeaderRange As String: S1HeaderRange = Find_Cell(y_Header, sDatenbereich)
Dim xValueRange As String: xValueRange = xCol & lStartRow & ":" & xCol & lStopRow
Dim S1ValueRange As String: S1ValueRange = S1Col & lStartRow & ":" & S1Col & lStopRow 'Series 1
ActiveSheet.ChartObjects(sDiagrammName).Activate
Set clsDiagramm.SVDO_Diagramm = ActiveSheet.ChartObjects(sDiagrammName).Chart
'Diagramm anordnen
With ActiveSheet.Shapes(sDiagrammName)
.Left = Range(sStartDiagramm).Left
.Top = Range(sStartDiagramm).Top
End With
With ActiveChart
.ChartType = xlColumnClustered
.ChartArea.Interior.ColorIndex = 40 'hellrosa wie MINITAB Tool
'Textobjekt 1 (Bemerkung)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 100, 1, 0, 0)
.Name = "Bemerkung" 'Hinweis zur Lage des Sensors
.TextFrame.Characters.Text = "Pumpentyp: " & sPumpentyp
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Bemerkung").Select
With Selection
.AutoScaleFont = False
.Font.Size = 10
.Font.Bold = False
End With
'Textobjekt 2 (Hinweis)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 90, 10, 200, 0)
.Name = "Hinweis"
.TextFrame.Characters.Text = _
"ACHTUNG: Diagrammwerte noch nicht geprüft"
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Hinweis").Select
With Selection
.AutoScaleFont = False
.Font.Size = 8
.Font.Bold = False
.Font.ColorIndex = 3 'rot
End With
'1. Datenreihe (+/-5 Sigmar-Werte)
'.SeriesCollection.NewSeries 'erste Datenreihe ist automatisch vorhanden
With .SeriesCollection(1)
.AxisGroup = 1 'muss auf Primärachse
.Name = Range(S1HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S1ValueRange)
.MarkerBackgroundColorIndex = 16
.MarkerForegroundColorIndex = 16
.MarkerStyle = xlSquare
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S1HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
End With
End With
'typische Darstellung für Histogramme:
ActiveChart.ChartGroups(1).GapWidth = 0
'd.h. kein Abstand zwischen den Säulen
'Titel kann erst hier aktiviert werden
.HasTitle = True
.ChartTitle.Text = sChartTitle
End With 'ActiveChart
On Error Resume Next 'Fehler unterdrücken wenn z.B. keine Gridlines aktiv
With ActiveChart
'Diagramfläche
With .ChartArea
.Select
'Keine Änderungen
End With
'DiagrammTitel
With .ChartTitle
.AutoScaleFont = False
.Font.Size = 12
.Font.Bold = True
.Left = 10
.Top = 4
End With
'Legende
With .Legend
.Position = xlLegendPositionBottom
.AutoScaleFont = False
.Font.Size = 8
.Left = 5
.Top = DiaHeight - 0
'.Width = DiaWidth - 0
End With
.HasLegend = True
'Zeichnungsfeld
With .PlotArea
.Interior.ColorIndex = xlAutomatic 'i.d.R Weiß
.Left = 20 'Platz lassen für Y-Achsenbezeichnung
.Top = 25 'Platz lassen für Diagrammtitel (fett)
.Height = 400 - 120 - 10 - 10
.Width = DiaWidth - 40
End With
'X-Achse
With .Axes(xlCategory)
.HasTitle = True
With .AxisTitle
.Characters.Text = x_Header
.AutoScaleFont = False
.Size = 10
End With
.HasMajorGridlines = True
.HasMinorGridlines = True
.CrossesAt = 0
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.TickLabels.NumberFormat = "0.0" 'Druck
.TickLabelSpacing = 1
.TickMarkSpacing = 1
' .MajorUnit = 1
' .MinorUnit = 0.5
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
.AxisBetweenCategories = True
.ReversePlotOrder = False
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Y1-Achse (Primary-Axes)
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "Anzahl"
.AutoScaleFont = False
.Size = 10
End With
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y-Achse
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MajorUnit = 20
' .MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
End With 'ActiveChart
'Diagramm_Formatieren 'Minitab ähnliche Darstellung
ActiveSheet.Shapes(sDiagrammName).Placement = xlFreeFloating 'd.h. unabhängig vom Autofilter
ActiveSheet.Range("B4").Select
ActiveWindow.Zoom = 85
Application.ScreenUpdating = True
End Function
Function Diagramm_XY_p() As Boolean
'2006-12-17
Const sDiagrammName As String = "QI_fp"
Const sDiagrammTitle As String = "Q,I = f(p)"
'Const iMinRPMskalierung As Integer = 1000 'Umdr./min
'Const iMinFlowkalierung As Integer = 100 'lph
Const p_Header As String = "p_b(bar)"
Const Q_Header As String = "Q_b(l/h)"
Const I_Header As String = "I(A)"
Diagramm_XY_p = True 'default
' ActiveSheet.ChartObjects.Delete 'default (alle Diagramme löschen); an dieser
' 'Stelle wichtig, da Benutzer ggf. ein Chart selektiert hat
ActiveSheet.Cells(1, 1).Activate
On Error Resume Next
ActiveSheet.ChartObjects(sDiagrammName).Delete 'falls vorhanden
Dim XY_Chart As ChartObject
Dim sChartTitle As String
Dim sPumpentyp As String: sPumpentyp = Range("B" & Find_Row("Typ:", "A:A")).Value
Dim lStartRow As Long: lStartRow = Find_Row("Muster", "A:A") + 1
Dim lStopRow As Long: lStopRow = ActiveCell(lStartRow, 1).CurrentRegion.Rows.Count: lStopRow = (lStopRow - 1) + (lStartRow - 1)
Dim sDatenbereich As String: sDatenbereich = Cells(lStartRow, 1).CurrentRegion.Address
Dim sStartDiagramm As String:
sStartDiagramm = Cells(lStartRow + 6, 3 + Cells(lStartRow, 1).CurrentRegion.Columns.Count).Address
'Default Diagrammgröße einstellen
intScaleDiaWidth = DiaWidth: intScaleDiaHeight = DiaHeight
'Skalierungswerte anhand des Maxiamalwertes der MAXIMUM-Zeile ermitteln
iY1AxesMaximumScale = WorksheetFunction.RoundUp(Range("F4"), 0) 'Ganzzahl
Application.ScreenUpdating = False
Set XY_Chart = ActiveSheet.ChartObjects.Add(DiaLeft, DiaTop, DiaWidth, DiaHeight)
XY_Chart.Name = sDiagrammName
sChartTitle = sDiagrammTitle
Dim xCol As String: xCol = Find_Column(p_Header, sDatenbereich)
Dim S1Col As String: S1Col = Find_Column(Q_Header, sDatenbereich)
Dim S2Col As String: S2Col = Find_Column(I_Header, sDatenbereich)
Dim xHeaderRange As String: xHeaderRange = Find_Cell(p_Header, sDatenbereich)
Dim S1HeaderRange As String: S1HeaderRange = Find_Cell(Q_Header, sDatenbereich)
Dim S2HeaderRange As String: S2HeaderRange = Find_Cell(I_Header, sDatenbereich)
Dim xValueRange As String: xValueRange = xCol & lStartRow & ":" & xCol & lStopRow
Dim S1ValueRange As String: S1ValueRange = S1Col & lStartRow & ":" & S1Col & lStopRow 'Series 1
Dim S2ValueRange As String: S2ValueRange = S2Col & lStartRow & ":" & S2Col & lStopRow 'Series 2
ActiveSheet.ChartObjects(sDiagrammName).Activate
Set clsDiagramm.SVDO_Diagramm = ActiveSheet.ChartObjects(sDiagrammName).Chart
'Diagramm anordnen
With ActiveSheet.Shapes(sDiagrammName)
.Left = Range(sStartDiagramm).Left
.Top = Range(sStartDiagramm).Top
End With
With ActiveChart
.ChartType = xlXYScatter
.ChartArea.Interior.ColorIndex = 40 'hellrosa wie MINITAB Tool
'Textobjekt 1 (Bemerkung)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 100, 1, 0, 0)
.Name = "Bemerkung" 'Hinweis zur Lage des Sensors
.TextFrame.Characters.Text = "Pumpentyp: " & sPumpentyp
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Bemerkung").Select
With Selection
.AutoScaleFont = False
.Font.Size = 10
.Font.Bold = False
End With
'Textobjekt 2 (Hinweis)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 35, 3, 200, 0)
.Name = "Hinweis"
.TextFrame.Characters.Text = _
"ACHTUNG: Diagrammwerte noch nicht geprüft"
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Hinweis").Select
With Selection
.AutoScaleFont = False
.Font.Size = 8
.Font.Bold = False
.Font.ColorIndex = 3 'rot
End With
'1. Datenreihe (Durchfluß Q)
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.AxisGroup = 1 'muss auf Primärachse
.Name = Range(S1HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S1ValueRange)
.MarkerBackgroundColorIndex = 16
.MarkerForegroundColorIndex = 16
.MarkerStyle = xlSquare
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S1HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
End With
End With
'2. Datenreihe (Strom I)
.SeriesCollection.NewSeries
With .SeriesCollection(2)
.AxisGroup = 2 'sollte immer auf Sekundärachse
.Name = Range(S2HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S2ValueRange)
.MarkerBackgroundColorIndex = 3 'red
.MarkerForegroundColorIndex = 3
.MarkerStyle = xlDot 'alternativ Punktdarstellung
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S2HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
End With
End With
'Titel kann erst hier aktiviert werden
.HasTitle = True
.ChartTitle.Text = sChartTitle
End With 'ActiveChart
On Error Resume Next 'Fehler unterdrücken wenn z.B. keine Gridlines aktiv
With ActiveChart
'Diagramfläche
With .ChartArea
.Select
'Keine Änderungen
End With
'DiagrammTitel
With .ChartTitle
.AutoScaleFont = False
.Font.Size = 12
.Font.Bold = True
.Left = 0
.Top = 0
End With
'Zeichnungsfeld
With .PlotArea
.Interior.ColorIndex = xlAutomatic 'i.d.R Weiß
.Left = 20 'Platz lassen für Y-Achsenbezeichnung
.Top = 25 'Platz lassen für Diagrammtitel (fett)
.Height = 400 - 120 - 10 - 10
.Width = 600 - 120 'Rand lassen
End With
'Legende
With .Legend
.Position = xlLegendPositionBottom
.AutoScaleFont = False
.Font.Size = 8
.Left = 0
.Top = DiaHeight - 10
.Width = DiaWidth - 2
End With
.HasLegend = True
'X-Achse
With .Axes(xlCategory)
.HasTitle = True
With .AxisTitle
.Characters.Text = "p [bar]"
.AutoScaleFont = False
.Size = 10
End With
.HasMajorGridlines = True
.HasMinorGridlines = True
.CrossesAt = 0
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.TickLabels.NumberFormat = "0.0" 'Druck
.TickLabelSpacing = 1
.TickMarkSpacing = 1
' .MajorUnit = 1
' .MinorUnit = 0.5
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
.AxisBetweenCategories = True
.ReversePlotOrder = False
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Y1-Achse (Primary-Axes)
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "Q [l/h]"
.AutoScaleFont = False
.Size = 10
End With
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y-Achse
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MajorUnit = 20
' .MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Y2-Achse (Secondary-Axes)
With .Axes(xlValue, xlSecondary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "I [A]"
.AutoScaleFont = False
.Size = 10
End With
.TickLabels.NumberFormat = "0.0" 'Strom
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MajorUnit = 20
' .MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
End With 'ActiveChart
'Diagramm_Formatieren 'Minitab ähnliche Darstellung
ActiveSheet.Shapes("QI_fp").Placement = xlFreeFloating 'd.h. unabhängig vom Autofilter
ActiveSheet.Range("B4").Select
ActiveWindow.Zoom = 85
Application.ScreenUpdating = True
'zum automatischen Aktualisieren von Array-Datenreihen ggf. folgende Prozedur mittels
'VBE in entsprechendes Tabellenblatt eintragen:
'Private Sub Worksheet_Calculate()
' Application.Run "'Gries.xla'!Modul_Diagramm.Q_n_Diagramm"
'End Sub
End Function
Function Diagramm_XY_n() As Boolean
Const sDiagrammName As String = "QI_fn"
Const sDiagrammTitle As String = "Q,I = f(n)"
Const iMinRpmSkalierung As Integer = 1000 'Umdr./min
Const iMinFlowSkalierung As Integer = 100 'lph
Const n_Header As String = "n(1/min)"
Const Q_Header As String = "Q_b(l/h)"
Const I_Header As String = "I(A)"
Diagramm_XY_n = True 'default
' ActiveSheet.ChartObjects.Delete 'default (alle Diagramme löschen); an dieser
' 'Stelle wichtig, da Benutzer ggf. ein Chart selektiert hat
ActiveSheet.Cells(1, 1).Activate
On Error Resume Next
ActiveSheet.ChartObjects(sDiagrammName).Delete 'falls vorhanden
On Error GoTo 0
Dim XY_Chart As ChartObject
Dim sChartTitle As String
Dim sPumpentyp As String: sPumpentyp = Range("B" & Find_Row("Typ:", "A:A")).Value
Dim lStartRow As Long: lStartRow = Find_Row("Muster", "A:A") + 1
Dim lStopRow As Long: lStopRow = ActiveCell(lStartRow, 1).CurrentRegion.Rows.Count: lStopRow = (lStopRow - 1) + (lStartRow - 1)
Dim sDatenbereich As String: sDatenbereich = Cells(lStartRow, 1).CurrentRegion.Address
Dim sStartDiagramm As String:
sStartDiagramm = Cells(lStartRow + 3, 2 + Cells(lStartRow, 1).CurrentRegion.Columns.Count).Address
'Default Diagrammgröße einstellen
intScaleDiaWidth = DiaWidth: intScaleDiaHeight = DiaHeight
'Skalierungswerte anhand des Maxiamalwertes der MAXIMUM-Zeile ermitteln
iY1AxesMaximumScale = WorksheetFunction.RoundUp(Range("F4"), 0) 'Ganzzahl
Application.ScreenUpdating = False
'2007-06-26
Dim bStatistik As Boolean
If Modul_Prüfstand.Test_Dateimerkmale_Prüfstand("Funktion (n)", "Mittelwert (1)", "Zähler (2)") Then
bStatistik = True
sStartDiagramm = "N2"
End If
Set XY_Chart = ActiveSheet.ChartObjects.Add(DiaLeft, DiaTop, DiaWidth, DiaHeight)
XY_Chart.Name = sDiagrammName
sChartTitle = sDiagrammTitle
Dim xCol As String: xCol = Find_Column(n_Header, sDatenbereich)
Dim S1Col As String: S1Col = Find_Column(Q_Header, sDatenbereich)
Dim S6Col As String: S6Col = Find_Column(I_Header, sDatenbereich)
Dim xHeaderRange As String: xHeaderRange = Find_Cell(n_Header, sDatenbereich)
Dim S1HeaderRange As String: S1HeaderRange = Find_Cell(Q_Header, sDatenbereich)
Dim S6HeaderRange As String: S6HeaderRange = Find_Cell(I_Header, sDatenbereich)
Dim xValueRange As String: xValueRange = xCol & lStartRow & ":" & xCol & lStopRow
Dim S1ValueRange As String: S1ValueRange = S1Col & lStartRow & ":" & S1Col & lStopRow 'Series 1 (Q)
Dim S6ValueRange As String: S6ValueRange = S6Col & lStartRow & ":" & S6Col & lStopRow 'Series 6 (I)
ActiveSheet.ChartObjects(sDiagrammName).Activate
Set clsDiagramm.SVDO_Diagramm = ActiveSheet.ChartObjects(sDiagrammName).Chart
'Diagramm anordnen
With ActiveSheet.Shapes(sDiagrammName)
.Left = Range(sStartDiagramm).Left
.Top = Range(sStartDiagramm).Top
End With
'Datenreihen erstellen
With ActiveChart
.ChartType = xlXYScatter
.ChartArea.Interior.ColorIndex = 40 'hellrosa wie MINITAB Tool
'Textobjekt 1 (Bemerkung)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 100, 1, 100, 20)
.Name = "Bemerkung" 'Hinweis zur Lage des Sensors
.TextFrame.Characters.Text = "Pumpentyp: " & sPumpentyp
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Bemerkung").Select
With Selection
.AutoScaleFont = False
.Font.Size = 10
.Font.Bold = False
End With
On Error GoTo 0
'Textobjekt 2 (Hinweis)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 3, 3, 200, 20)
.Name = "Hinweis"
If bStatistik Then
.TextFrame.Characters.Text = _
"ACHTUNG: wenn blaue Referenzlinie senkrecht = Pumpentyp unbekannt"
Else
.TextFrame.Characters.Text = _
"ACHTUNG: für Drehzahlgrenzendarstellung Statistikblock hinzufügen"
End If
.Width = 300
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Hinweis").Select
With Selection
.AutoScaleFont = False
.Font.Size = 8
.Font.Bold = False
.Font.ColorIndex = 3 'rot
End With
Dim iMarkerColor As Integer
iMarkerColor = Get_SVDO_Colors("n(1/min)")
'1. Datenreihe (Durchfluß Q)
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.AxisGroup = 1 'muss auf Primärachse
.Name = Range(S1HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S1ValueRange)
.MarkerBackgroundColorIndex = iMarkerColor
.MarkerForegroundColorIndex = iMarkerColor
.MarkerStyle = xlSquare
.MarkerStyle = xlCircle
'.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 4
.MarkerSize = 3
'.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S1HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
.LineStyle = xlNone
End With
End With
If bStatistik Then
Dim iYaxisAutoOldMin As Double
Dim iYaxisAutoOldMax As Double
iYaxisAutoOldMin = .Axes(xlValue, xlPrimary).MinimumScale
iYaxisAutoOldMax = .Axes(xlValue, xlPrimary).MaximumScale
Dim nLower As Double, nMean As Double, nUpper As Double
Dim ylower As Double, yMean As Double, yUpper As Double
nMean = Range("D4")
yMean = Range("I4")
Dim dSlope As Double, db As Double
dSlope = 1000# 'keine Steigung zu Indikation dass kein Typ bekannt (default)
'Achtung: ungleich 0, da sonst Laufzeitfehler bei Division
If VBA.InStr(1, sPumpentyp, "s") Then 'Sonderfall: Steigungsangabe in Typ
On Error Resume Next
dSlope = VBA.CCur(VBA.Mid(sPumpentyp, 2)) / 1000
On Error GoTo 0
End If
If VBA.InStr(1, sPumpentyp, "4.2") Then
dSlope = Get_Pumptype_Slope("4.2")
End If
If VBA.InStr(1, sPumpentyp, "4.42") Then
dSlope = Get_Pumptype_Slope("4.42")
End If
If VBA.InStr(1, sPumpentyp, "4.6") Then
dSlope = Get_Pumptype_Slope("4.6")
End If
'hier: kritische Programmierung
If VBA.InStr(1, sPumpentyp, "eta") Then 'ggf überschreibt 4.6 standard
dSlope = Get_Pumptype_Slope("4.6eta")
End If
If VBA.InStr(1, sPumpentyp, "5.7") Then
dSlope = Get_Pumptype_Slope("5.7")
End If
If VBA.InStr(1, sPumpentyp, "6.6") Then
dSlope = Get_Pumptype_Slope("6.6")
End If
If VBA.InStr(1, sPumpentyp, "8.6") Then
dSlope = Get_Pumptype_Slope("8.6")
End If
If VBA.InStr(1, sPumpentyp, "11") Or _
VBA.InStr(1, sPumpentyp, "11.0") Then
dSlope = Get_Pumptype_Slope("11.0")
End If
'y = ax + b wobei a = sSlope = bekannt
'Berechnung von b (Achsenabschnitt)
'b = y - ax
db = yMean - (dSlope * nMean)
'Berecnung von Unter- und Obergrenze mittels x-Wert
nLower = 1000
nUpper = 8000
ylower = (dSlope * nLower) + db
yUpper = (dSlope * nUpper) + db
'Berecnung von Unter- und Obergrenze mittels y-Wert
'y = ax + b wobei a=sSlope und b=db bekannt
'Berechnung von x (Drehzahlgrenzen)
'x = (y - b) / a
ylower = iYaxisAutoOldMin
yUpper = iYaxisAutoOldMax
nLower = (ylower - db) / dSlope
nUpper = (yUpper - db) / dSlope
'Spezielle Zellen benennen
Dim sASname As String: sASname = ActiveSheet.Name
ActiveWorkbook.Names.Add Name:="Steigung", _
RefersToR1C1:="='" & sASname & "'!R1C5"
ActiveWorkbook.Names.Add Name:="Achsenabschnitt", _
RefersToR1C1:="='" & sASname & "'!R1C6"
ActiveWorkbook.Names.Add Name:="REF_n_neg", _
RefersToR1C1:="='" & sASname & "'!R15C3"
ActiveWorkbook.Names.Add Name:="REF_n_pos", _
RefersToR1C1:="='" & sASname & "'!R15C5"
Range("D1:F2").Font.ColorIndex = 2 'weiss
Range("I1:I2").Font.ColorIndex = 2 'weiss
Range("D1").Formula = "=(I1-F1)/E1" 'untere Drehzahlgrenze
Range("D2").Formula = "=(I2-F2)/E2" 'obere Drehzahlgrenze
Range("F1").Formula = "=I4-(E1*D4)" 'Formel für Achsenabschnitt
'Range("E1").Formula = "=I4-(Steigung*D4)" 'Formel für Achsenabschnitt
'' Zellennamen erst ab XL2007 da, dann pro Sheet unterscheidbar
Range("F2").Formula = "=F1" 'Formel für Achsenabschnitt kopieren
Range("E1").Value = dSlope 'Wert für Steigung
Range("E2").Formula = "=E1" 'Wert für Steigung kopieren
Range("I1").Formula = "=I6-10"
Range("I2").Formula = "=I7+10"
'Formeln für automatische Diagrammaktualisierung in Tabelle eintragen
'Range("C16:H17").Font.ColorIndex = Range("C16").Font.Background
'und Daten unsichtbar machen
Range("C15:H17").Font.ColorIndex = 2 'weiss
'On Error GoTo 0
Range("D16").Formula = "=D4"
Range("D17").Formula = "=D16"
Range("G16").Formula = "=I6-10"
Range("G17").Formula = "=I7+10"
Range("C15").Value = 5 'Prozentwert
'Range("C16").Formula = "=D4*0.95"
Range("C16").Formula = "=D4*(1-C15/100)"
Range("C17").Formula = "=C16"
Range("F16").Formula = "=I6-10"
Range("F17").Formula = "=I7+10"
Range("E15").Value = 5 'Prozentwert
'Range("E16").Formula = "=D4*1.05"
Range("E16").Formula = "=D4*(1+E15/100)"
Range("E17").Formula = "=E16"
Range("H16").Formula = "=I6-10"
Range("H17").Formula = "=I7+10"
'
'2. Datenreihe (Trendline vom Mittelwert)
.SeriesCollection.NewSeries
With .SeriesCollection(2)
.AxisGroup = 1 'auf Primärachse
.Name = "Q (Trend)"
' .XValues = Array(nLower, nMean, nUpper)
' .Values = Array(ylower, yMean, yUpper)
.XValues = Range("D1:D2")
.Values = Range("I1:I2")
.MarkerBackgroundColorIndex = iMarkerColor
.MarkerForegroundColorIndex = iMarkerColor
' .MarkerStyle = xlSquare
' .MarkerStyle = xlCircle
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 4
.MarkerSize = 3
'.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = 5 'Blau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
End If
If bStatistik Then
'3. Datenreihe (Referenzdrehzahl)
.SeriesCollection.NewSeries
With .SeriesCollection(3)
.AxisGroup = 1 'auf Primärachse
.Name = "Ref n"
' .XValues = Array(nMean, nMean)
' .Values = Array(iYaxisAutoOldMin, iYaxisAutoOldMax)
' .XValues = Range(Cells(1, 4), Cells(2, 4)) 'liefert nur Einzelwerte
.XValues = Range("D16:D17")
.Values = Range("G16:G17")
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
With .Border
.ColorIndex = 9 'Braun
.Weight = xlHairline
.LineStyle = xlDash
End With
End With
'4. Datenreihe (Referenzdrehzahl -5%)
.SeriesCollection.NewSeries
With .SeriesCollection(4)
.AxisGroup = 1 'auf Primärachse
.Name = "Ref n-5%"
' .XValues = Array(nMean * 0.95, nMean * 0.95)
' .Values = Array(iYaxisAutoOldMin, iYaxisAutoOldMax)
.XValues = Range("C16:C17")
.Values = Range("F16:F17")
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
With .Border
.ColorIndex = 9 'Braun
.Weight = xlHairline
.LineStyle = xlDot
End With
End With
'5. Datenreihe (Referenzdrehzahl +5%)
.SeriesCollection.NewSeries
With .SeriesCollection(5)
.AxisGroup = 1 'auf Primärachse
.Name = "Ref n+5%"
' .XValues = Array(nMean * 1.05, nMean * 1.05)
' .Values = Array(iYaxisAutoOldMin, iYaxisAutoOldMax)
.XValues = Range("E16:E17")
.Values = Range("H16:H17")
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
With .Border
.ColorIndex = 9 'Braun
.Weight = xlHairline
.LineStyle = xlDot
End With
End With
'6. Datenreihe (Strom I)
'2007-09-05 hinzu
.SeriesCollection.NewSeries
With .SeriesCollection(6)
.AxisGroup = 2 'muss auf Sekundärachse
.Name = Range(S6HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S6ValueRange)
.MarkerBackgroundColorIndex = Get_SVDO_Colors("I(A)")
.MarkerForegroundColorIndex = Get_SVDO_Colors("I(A)")
.MarkerStyle = xlSquare
.MarkerStyle = xlCircle
'.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 4
.MarkerSize = 3
'.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S6HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
.LineStyle = xlNone
End With
End With
'Reihenfolge für Legende festlegen
With .ChartGroups(1)
'ACHTUNG: PlotOrder ändert SeriesCollection Reihenfolge
'Q_b Ref_n-5%
'Q_Trend Ref_n
'Ref_n Ref_n+5%
'Ref_n-5% Q_b
'Ref_n+5% Q_Trend
On Error Resume Next 'xl2007
.SeriesCollection(2).PlotOrder = 5
.SeriesCollection(1).PlotOrder = 4
.SeriesCollection(1).PlotOrder = 2
On Error GoTo 0
End With
End If
' Achsen formatieren
With .Axes(xlCategory, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "n [1/min]"
.AutoScaleFont = False
End With
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
Dim iMinCatScale As Integer: iMinCatScale = .MinimumScale - 100 'offset
Dim iMaxCatScale As Integer: iMaxCatScale = .MaximumScale
'Variablen hier einfacher zu debuggen
If (iMaxCatScale - iMinCatScale) < iMinRpmSkalierung Then
'Skalierung auf Mindesbreite einstellen
iMaxCatScale = iMinCatScale + iMinRpmSkalierung
.MinimumScale = iMinCatScale
.MaximumScale = iMaxCatScale
.MinorUnit = 100
.MajorUnit = 200
End If
' With .TickLabels
' .Alignment = xlCenter
' .Offset = 100
' .ReadingOrder = xlContext
' .Orientation = xlTickLabelOrientationAutomatic
' End With
End With
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "Q [l/h]"
.AutoScaleFont = False
' .Size = 10
.Font.Size = 10 'xl2007
End With
.HasMajorGridlines = True
.HasMinorGridlines = False 'Keine Hilfslinien
'.MinimumScale = 0
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MaximumScale = iY1AxesMaximumScale
' .MajorUnit = iY1AxesMaximumScale / 10
'Max-Skalierung der Y1-Achse sichern für Übernahme Y2-Achse
iY2AxesMaximumScale = .MaximumScale 'Wert für 2. Achse sichern
Debug.Print iY2AxesMaximumScale
Dim iMinScale As Integer: iMinScale = .MinimumScale
Dim iMaxScale As Integer: iMaxScale = .MaximumScale
'Variablen hier einfacher zu debuggen
'iMinScale = (iMinScale / 10) * 10 'Runden auf Zehner
iMinScale = iMinScale / 10: iMinScale = iMinScale * 10 'Runden auf Zehner
iMinScale = iMinScale - 20 'offset
If (iMaxScale - iMinScale) < iMinFlowSkalierung Then
'Skalierung auf Mindesbreite einstellen
iMaxScale = iMinScale + iMinFlowSkalierung
.MinimumScale = iMinScale
.MaximumScale = iMaxScale
.MinorUnit = 10
.MajorUnit = 20
End If
.ScaleType = xlLinear
.DisplayUnit = xlNone
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y1-Achse
End With
If bStatistik Then
With .Axes(xlValue, xlSecondary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "I [A]"
.AutoScaleFont = False
' .Size = 10
.Font.Size = 10 'xl2007
End With
'.MinimumScale = 0
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
iY2AxesMaximumScale = .MaximumScale 'Wert für 2. Achse sichern
Debug.Print iY2AxesMaximumScale
.ScaleType = xlLinear
.DisplayUnit = xlNone
.TickLabels.AutoScaleFont = False ' festes Format
.TickLabels.NumberFormat = "0.0" 'Zahlendarstellung Y2-Achse
.TickLabels.Font.Size = 10 'SVDO Größe
End With
End If 'bStatistik
.HasTitle = True
.ChartTitle.Text = sChartTitle
End With 'ActiveChart
'On Error Resume Next 'Fehler unterdrücken wenn z.B. keine Gridlines aktiv
With ActiveChart
'Diagramfläche
With .ChartArea
.Select
'Keine Änderungen
End With
'DiagrammTitel
With .ChartTitle
.AutoScaleFont = False
.Font.Size = 12
.Font.Bold = True
.Left = 0
.Top = 0
End With
'Zeichnungsfeld
With .PlotArea
.Interior.ColorIndex = xlAutomatic 'i.d.R Weiß
.Left = 20 'Platz lassen für Y-Achsenbezeichnung
.Top = 25 'Platz lassen für Diagrammtitel (fett)
.Height = 400 - 120 - 10 - 10
' .Width = 600 - 300 'Rand lassen
.Width = 600 - 320 'Rand größer wegen Stromachse hinzu
End With
'X-Achse
With .Axes(xlCategory)
.HasMajorGridlines = True
.HasMinorGridlines = True
.CrossesAt = 0
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.TickLabels.NumberFormat = "0" 'Spannung
' .TickLabelSpacing = 1
' .TickMarkSpacing = 1
' .MajorUnit = 1
' .MinorUnit = 0.5
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
' .AxisBetweenCategories = True
.ReversePlotOrder = False
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
'Grenzbedingung
If .MinimumScale < 0 Then
.MinimumScale = 0
End If
End With
'Y1-Achse (Primary-Axes)
With .Axes(xlValue, xlPrimary)
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y-Achse
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MajorUnit = 20
' .MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
' With .MinorGridlines.Border
' .ColorIndex = 15 '15=hellstes grau
' .Weight = xlHairline
' .LineStyle = xlContinuous
' End With
'Grenzbedingung
If .MinimumScale < 0 Then
.MinimumScale = 0
End If
End With
On Error GoTo 0
'Legende
With .Legend
.Position = xlLegendPositionBottom
.AutoScaleFont = False
.Font.Size = 8
.Left = 10
.Top = DiaHeight - 30
.Width = DiaWidth - 25
' If XLVER = 12 Then
' .Format.Fill.BackColor.SchemeColor = 2 'xl2007
' .Format.Line.BackColor.SchemeColor = 3 'xl2007
' End If
End With
.HasLegend = True
End With 'ActiveChart
ActiveSheet.Shapes("QI_fn").Placement = xlFreeFloating 'd.h. unabhängig vom Autofilter
ActiveSheet.Range("B4").Select
ActiveWindow.Zoom = 85
Application.ScreenUpdating = True
End Function
Function Diagramm_XY_U() As Boolean
Const sDiagrammName As String = "QI_fU"
Const sDiagrammTitle As String = "Q,I,p = f(U)"
Diagramm_XY_U = True 'default
' ActiveSheet.ChartObjects.Delete 'default (alle Diagramme löschen); an dieser
' 'Stelle wichtig, da Benutzer ggf. ein Chart selektiert hat
ActiveSheet.Cells(1, 1).Activate
On Error Resume Next
ActiveSheet.ChartObjects(sDiagrammName).Delete 'falls vorhanden
Dim XY_Chart As ChartObject
Dim sChartTitle As String
Dim sPumpentyp As String: sPumpentyp = Range("B" & Find_Row("Typ:", "A:A")).Value
Dim lStartRow As Long: lStartRow = Find_Row("Muster", "A:A") + 1
Dim lStopRow As Long: lStopRow = ActiveCell(lStartRow, 1).CurrentRegion.Rows.Count: lStopRow = (lStopRow - 1) + (lStartRow - 1)
Dim sDatenbereich As String: sDatenbereich = Cells(lStartRow, 1).CurrentRegion.Address
Dim sStartDiagramm As String:
sStartDiagramm = Cells(lStartRow, 1 + Cells(lStartRow, 1).CurrentRegion.Columns.Count).Address
'Default Diagrammgröße einstellen
intScaleDiaWidth = DiaWidth: intScaleDiaHeight = DiaHeight
'Skalierungswerte anhand des Maxiamalwertes der MAXIMUM-Zeile ermitteln
iY1AxesMaximumScale = WorksheetFunction.RoundUp(Range("F4"), 0) 'Ganzzahl
Application.ScreenUpdating = False
Set XY_Chart = ActiveSheet.ChartObjects.Add(DiaLeft, DiaTop, DiaWidth, DiaHeight)
XY_Chart.Name = sDiagrammName
sChartTitle = sDiagrammTitle
Dim xCol As String: xCol = Find_Column("U(V)", sDatenbereich)
Dim S1Col As String: S1Col = Find_Column("Q_b(l/h)", sDatenbereich)
Dim S2Col As String: S2Col = Find_Column("I(A)", sDatenbereich)
Dim S3Col As String: S3Col = Find_Column("p_b(bar)", sDatenbereich)
Dim xHeaderRange As String: xHeaderRange = Find_Cell("U(V)", sDatenbereich)
Dim S1HeaderRange As String: S1HeaderRange = Find_Cell("Q_b(l/h)", sDatenbereich)
Dim S2HeaderRange As String: S2HeaderRange = Find_Cell("I(A)", sDatenbereich)
Dim S3HeaderRange As String: S3HeaderRange = Find_Cell("p_b(bar)", sDatenbereich)
Dim xValueRange As String: xValueRange = xCol & lStartRow & ":" & xCol & lStopRow
Dim S1ValueRange As String: S1ValueRange = S1Col & lStartRow & ":" & S1Col & lStopRow 'Series 1
Dim S2ValueRange As String: S2ValueRange = S2Col & lStartRow & ":" & S2Col & lStopRow 'Series 2
Dim S3ValueRange As String: S3ValueRange = S3Col & lStartRow & ":" & S3Col & lStopRow 'Series 3
ActiveSheet.ChartObjects(sDiagrammName).Activate
'Diagramm anordnen
With ActiveSheet.Shapes(sDiagrammName)
.Left = Range(sStartDiagramm).Left
.Top = Range(sStartDiagramm).Top
End With
'Datenreihen erstellen
With ActiveChart
.ChartType = xlXYScatter
.ChartArea.Interior.ColorIndex = 40 'hellrosa wie MINITAB Tool
'Textobjekt 1 (Bemerkung)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 100, 1, 0, 0)
.Name = "Bemerkung" 'Hinweis zur Lage des Sensors
.TextFrame.Characters.Text = "Pumpentyp: " & sPumpentyp
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Bemerkung").Select
With Selection
.AutoScaleFont = False
.Font.Size = 10
.Font.Bold = False
End With
'Textobjekt 2 (Hinweis)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 15, 3, 200, 0)
.Name = "Hinweis"
.TextFrame.Characters.Text = _
"ACHTUNG: Diagrammwerte noch nicht geprüft"
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Hinweis").Select
With Selection
.AutoScaleFont = False
.Font.Size = 8
.Font.Bold = False
.Font.ColorIndex = 3 'rot
End With
'1. Datenreihe (Durchfluß Q)
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.AxisGroup = 1 'muss auf Primärachse
.Name = Range(S1HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S1ValueRange)
.MarkerBackgroundColorIndex = 16
.MarkerForegroundColorIndex = 16
.MarkerStyle = xlSquare
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S1HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
End With
End With
'2. Datenreihe (Strom I)
.SeriesCollection.NewSeries
With .SeriesCollection(2)
.AxisGroup = 2 'sollte immer auf Sekundärachse
.Name = Range(S2HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S2ValueRange)
.MarkerBackgroundColorIndex = 3 'red
.MarkerForegroundColorIndex = 3
.MarkerStyle = xlDot 'alternativ Punktdarstellung
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S2HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
End With
End With
'3. Datenreihe (Druck p)
.SeriesCollection.NewSeries
With .SeriesCollection(3)
.AxisGroup = 2 'sollte auf Stromachse
.Name = Range(S3HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S3ValueRange)
.MarkerBackgroundColorIndex = 16
.MarkerForegroundColorIndex = 16
.MarkerStyle = xlSquare
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S3HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
End With
End With
' Achsen formatieren
With .Axes(xlCategory, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "U [V]"
.AutoScaleFont = False
End With
.MinimumScale = 5
.MaximumScale = 15
'.MaximumScaleIsAuto = True
.HasMajorGridlines = False 'keine vertikalen Haupt-Linien
.HasMinorGridlines = False
With .TickLabels
.Alignment = xlCenter
.offset = 100
.ReadingOrder = xlContext
.Orientation = xlTickLabelOrientationAutomatic
End With
End With
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "Q [l/h]"
.AutoScaleFont = False
End With
.HasMajorGridlines = True
.HasMinorGridlines = False 'Keine Hilfslinien
.MinimumScale = 0
.MaximumScaleIsAuto = True
' .MaximumScale = iY1AxesMaximumScale
' .MajorUnit = iY1AxesMaximumScale / 10
'Max-Skalierung der Y1-Achse sichern für Übernahme Y2-Achse
iY2AxesMaximumScale = .MaximumScale 'Wert für 2. Achse sichern
Debug.Print iY2AxesMaximumScale
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.ScaleType = xlLinear
.DisplayUnit = xlNone
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y1-Achse
End With
With .Axes(xlValue, xlSecondary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "I [A], p [bar]"
.AutoScaleFont = False
End With
.TickLabels.NumberFormat = "0.0" 'Zahlendarstellung Y2-Achse
End With
'X-Achse
With .Axes(xlCategory)
.HasTitle = True
With .AxisTitle
.Characters.Text = "U [V]"
.AutoScaleFont = False
End With
.HasMajorGridlines = True
.HasMinorGridlines = True
.CrossesAt = 0
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.TickLabels.NumberFormat = "0" 'Spannung
.TickLabelSpacing = 1
.TickMarkSpacing = 1
' .MajorUnit = 1
' .MinorUnit = 0.5
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
.AxisBetweenCategories = True
.ReversePlotOrder = False
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Y1-Achse (Primary-Axes)
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "Q [l/h]"
.AutoScaleFont = False
End With
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y-Achse
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MajorUnit = 20
' .MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Y2-Achse (Secondary-Axes)
With .Axes(xlValue, xlSecondary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "I [A], p [bar]"
.AutoScaleFont = False
End With
.TickLabels.NumberFormat = "0.0" 'Strom
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MajorUnit = 20
' .MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
.HasTitle = True
'DiagrammTitel
With .ChartTitle
.Text = sChartTitle
.AutoScaleFont = False
.Font.Size = 12
.Font.Bold = True
.Left = 0
.Top = 0
End With
End With 'ActiveChart
Diagramm_Formatieren
With ActiveChart
'Legende
With .Legend
.Position = xlLegendPositionBottom
.AutoScaleFont = False
.Font.Size = 8
.Left = 1
.Top = DiaHeight - 10
.Width = DiaWidth - 2
End With
.HasLegend = True
End With
ActiveSheet.Shapes("QI_fU").Placement = xlFreeFloating 'd.h. unabhängig vom Autofilter
ActiveSheet.Range("B4").Select
ActiveWindow.Zoom = 85
Application.ScreenUpdating = True
End Function
Sub Diagramm_Formatieren()
'Diagramm in einer Minitab(Default) ähnlichen Darstellungsform
'Letzte Änderung: 2006-12-18
'On Error Resume Next 'Fehler unterdrücken wenn z.B. keine Gridlines aktiv
Const DiaWidth As Integer = 400
Const DiaHeight As Integer = 300
With ActiveChart
'Diagramfläche
With .ChartArea
.Select
'Keine Änderungen
End With
'DiagrammTitel
With .ChartTitle
.AutoScaleFont = False
.Font.Size = 12
.Font.Bold = True
.Left = 0
.Top = 0
End With
'Zeichnungsfeld
With .PlotArea
.Interior.ColorIndex = xlAutomatic 'i.d.R Weiß
.Left = 20 'Platz lassen für Y-Achsenbezeichnung
.Top = 25 'Platz lassen für Diagrammtitel (fett)
.Height = DiaHeight - 120 - 10 - 10
.Width = DiaWidth - 120 'Rand lassen
End With
'X-Achse
With .Axes(xlCategory)
.HasMajorGridlines = True 'einschalten
.HasMinorGridlines = False 'aus
.CrossesAt = 0
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.TickLabels.NumberFormat = "0" 'Spannung
.TickLabelSpacing = 1
.TickMarkSpacing = 1
.MajorUnit = 1
.MinorUnit = 0.5
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
.AxisBetweenCategories = True
.ReversePlotOrder = False
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Y1-Achse (Primary-Axes)
With .Axes(xlValue, xlPrimary)
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y-Achse
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MajorUnit = 20
.MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Y2-Achse (Secondary-Axes)
With .Axes(xlValue, xlSecondary)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
'.MaximumScale = iY2AxesMaximumScale 'Wert der Y1-Achse übernehmen
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
.MajorUnit = 2
.MinorUnit = 1
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y-Achse
.TickLabels.Font.Size = 10
.TickLabelPosition = xlNextToAxis 'e.g. xLNone
'.TickLabelPosition = xlNone 'e.g. xLNone
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.DisplayUnit = xlNone
.HasDisplayUnitLabel = True
With .Border
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
'Legende
With .Legend
.Position = xlLegendPositionBottom
.AutoScaleFont = False
.Font.Size = 8
.Left = 1
.Top = DiaHeight - 1
.Width = DiaWidth - 2
End With
.HasLegend = True
End With 'ActiveChart
End Sub
Function Get_SVDO_Colors(sEinheit) As Integer
'Vereinheitlicht die Farben der Diagramme bei SVDO
'Integerwert für COLORINDEX Eigenschaft
'Liste der Farbwerte s. Makro: Farbtabelle
Dim colColor As New Collection
colColor.Add 1, "U(V)" 'schwarz
colColor.Add 3, "I(A)" 'rot
colColor.Add 10, "n(1/min)" 'grün
colColor.Add 8, "p_a(bar)" 'türkis
colColor.Add 7, "Q_a(l/h)" 'violett
colColor.Add 9, "Eta(%)" 'braun
colColor.Add 8, "p_b(bar)" 'türkis
colColor.Add 5, "Q_b(l/h)" 'blau
Get_SVDO_Colors = colColor(sEinheit)
Debug.Print "Colorindex: "; colColor(sEinheit)
End Function
Attribute VB_Name = "Modul_ENH"
'(c) 2009, Michael Gries
'Erstellung: 2009-11-27 (Hypercom)
'Letzte Änderung: 2010-05-14
'
'Pivot-Tabellen Lage
Public Const sTablePRFDestinationAddress = "R10C1"
Public Const sTableFT2DestinationAddress = "R35C1"
Sub DateiLaden_ENH()
' Konstanten
Const DateiFilterTyp As String = "ENH-Rohdaten (*.xls),*.xls"
Const DialogÖffnenTitle As String = "Öffnen: Qualitätszahlen ENH"
Const strSQAdateiMerkmal As String = "QSYS-Report"
Dim WorkbookSaveAsName As String
Dim i As Integer
Dim l As Long
Dim Mappen As Variant
Dim str As String
Dim strScrollAreaRange As String
Dim auflistung As New VBA.Collection
l = 0
Mappen = Application.GetOpenFilename(DateiFilterTyp, Title:=DialogÖffnenTitle, MultiSelect:=True)
If IsArray(Mappen) Then
For l = LBound(Mappen) To UBound(Mappen)
Workbooks.Open Mappen(l)
Next l
Else
'MsgBox "Es wurde keine Datei ausgewählt! "
Exit Sub
End If
' Datei Kopfzeilen vorbereiten
''auflistung.Add "Wname", "planid"
''auflistung.Add "Teilnummer", "partnb"
''auflistung.Add "Name", "id"
Sheets(1).Name = "Data" 'umbenennen
Range("A:A").Select
'With Selection
' .Find(What:=strSQAdateiMerkmal).Activate
' Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 0)).EntireRow.Insert
'End With
'
'For i = 1 To auflistung.Count Step 1
'' Cells(1, i).Value = auflistung(i) 'collection typ beginnt bei 1
''Next i
'
'Zellnamen festlegen
''For i = 1 To auflistung.Count Step 1
'' Range(Cells(1, i), Cells(1, i)).Select
'' On Error Resume Next 'Name-Definitionen dürfen z.B. keine Leerzzeichen enthalten
'' ActiveSheet.Names.Add Name:=auflistung(i), RefersToR1C1:=Selection
''Next i
' Zeilen formatieren
Range("A2:I5").MergeCells = False 'sind in Originaldaten als verbundene Zelle
Range("Filter!A2:D5").MergeCells = False 'sind in Originaldaten als verbundene Zelle
'Range("Filter!A6:D6").Select 'als Kopfzeile markieren - nur für Optik
'Sheets.Add before:=Sheets(1)
'Sheets("Tabelle1").Name = "Data2"
Sheets("Data").Select
Sheets("Data").AutoFilterMode = False 'wird später definiert gesetzt
'Range("Image!A2:P5").MergeCells = False 'sind in Originaldaten als verbundene Zelle
''Range("A1:I1").Delete Shift:=xlUp
' Spalten formatieren
Range("D:F").NumberFormat = "0"
Range("G:H").NumberFormat = "0.0"
Range("D:H").HorizontalAlignment = xlRight
''Range("1:2").Font.Bold = True 'die ersten beiden Kopfzeilen fett darstellen
''Range("1:1").Font.ColorIndex = 5 'eingefügte Zeile blau darstellen
''Range("K:K").Font.ColorIndex = 3 'Exceed Werte rot färben
' Gruppierungen festlegen
''Columns("E:E").Group
''Columns("M:P").Group
' Fenster Einstellungen
With ActiveWindow
.SplitRow = 6
' .SplitColumn = 2
.FreezePanes = True
.Zoom = 100
End With
'With ActiveSheet.Outline
' .AutomaticStyles = False
' .SummaryRow = xlAbove
' .SummaryColumn = xlLeft
' .ShowLevels RowLevels:=1, ColumnLevels:=1
'End With
'
'Kopfzeilen einstellen
'Rows(1).RowHeight = Rows(2).RowHeight
With Rows(6)
.RowHeight = 25 'px fester Wert wegen Autofilter
.VerticalAlignment = xlTop
.Font.Bold = True
.AutoFilter
.OutlineLevel = 1
End With
'erst an Ende der Zeilen-/Spaltenformatierung
Range("A:I").Columns.AutoFit
Columns(1).ColumnWidth = 8 'wegen Überschrift
'Dokumentbereich einschränken
''ActiveSheet.UsedRange.Select
'''With Selection.Borders
''' .LineStyle = xlContinuous
'''End With
''
''strScrollAreaRange = Selection.Address
''ActiveSheet.ScrollArea = strScrollAreaRange
'ActiveCell.CurrentRegion.Select 'hier identisch mit UsedRange
With Application
.CutCopyMode = False 'keine Zellmarkierung
.ActiveWindow.DisplayGridlines = False
End With
' Dokument Eigenschaften
With ActiveWorkbook ' or for add-ins use "ThisWorkbook"
.BuiltinDocumentProperties("Title").Value = ActiveSheet.Name
.BuiltinDocumentProperties("Subject").Value = "ENH Qualitätsdaten Auswertung"
.BuiltinDocumentProperties("Company").Value = "Hypercom GmbH"
.BuiltinDocumentProperties("Manager").Value = "Michael Gries"
.BuiltinDocumentProperties("Author").Value = "created by VBA (Gries.xla)"
.BuiltinDocumentProperties("Last Author").Value = "created by VBA (Gries.xla)"
.BuiltinDocumentProperties("Application Name").Value = "Auswertung"
.BuiltinDocumentProperties("Category").Value = "Quality"
.BuiltinDocumentProperties("Comments").Value = "ENH"
.BuiltinDocumentProperties("Keywords").Value = "Products"
End With
With ActiveWorkbook
.CustomDocumentProperties.Add Name:="Makro Ansprechpartner", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="Gries"
.CustomDocumentProperties.Add Name:="Macro Version", _
LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=2
.CustomDocumentProperties.Add Name:="Abteilung", _
LinkToContent:=False, Type:=msoPropertyTypeString, Value:="Quality"
End With
With ActiveSheet
.CustomProperties.Add Name:="Ansprechpartner", Value:="M. Gries"
.CustomProperties.Add Name:="Telefon", Value:="+49 6621 84 691"
End With
Range("A3:I4").Select
'Arbeitsmappe speichern
'WorkbookSaveAsName = VBA.Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & ".xls"
'ActiveWorkbook.SaveAs Filename:=WorkbookSaveAsName, FileFormat:=xlNormal
ActiveWorkbook.AddToFavorites ' Verknüpfung zum Favoritenordner
With Application
.DisplayStatusBar = True
.StatusBar = "Daten wurden als Excel-Datei: " & WorkbookSaveAsName & " gesichert"
End With
l = Timer
Do While Timer < l + 2
DoEvents
Loop
Application.StatusBar = False
CheckFilter
'Pivot Tabellen hinzufügen
PivotPRF ("Data!R6C1:R1000C11")
PivotProdukte ("Data!R6C1:R1000C11")
'Pivotblatt umbenennen und verschieben
Sheets("Data").Tab.ColorIndex = 36
Sheets("Image").Name = "Pivot"
Sheets("Pivot").Tab.ColorIndex = 34
Dim CodeModuleSheet
CodeModuleSheet = ActiveSheet.Name
AddStatistik
AddStatistikCode
AddZeilenCode
AddDiagramPRF
AddDiagramFT2
'Diagramm_XY_ENH
End Sub
'2010-05-14, 2010-05-11, 2009-11-28
Sub CheckFilter()
Const csCriteria = "Offset"
Const csPRF = "PRF (ICT/ FPT / BST)"
Const csASS = "Endmontage"
Const csFT2 = "Produkte & Systeme"
Dim ProductGroup As New Collection
ProductGroup.Add "ACR", "ACR"
ProductGroup.Add "AHT", "AHT"
ProductGroup.Add "APH", "APH"
ProductGroup.Add "APU", "APU"
ProductGroup.Add "EPP_V5", "EPP_V5"
ProductGroup.Add "EPP_V6", "EPP_V6"
ProductGroup.Add "medHybrid", "medHybrid"
Const csToleranz = "Toleranz"
Const csJahr = "Jahr"
Const csOffset = "offset Start"
Const csCWstart = "Kalenderwoche Start [KW]"
Dim year
Dim offset
Dim week
Dim sWeek
Sheets("Filter").Select
Range("A7").Value = csToleranz
Range("A8").Value = csJahr
Range("A9").Value = csOffset
Range("A10").Value = csCWstart
Range("A7:C1000").Select
With Selection
.Find(What:=csCriteria).Activate
year = ActiveCell.offset(-1, 2)
offset = ActiveCell.offset(0, 2)
week = ActiveCell.offset(1, 2)
End With
Debug.Print "year: "; year; " offset: "; offset; " week: "; week
Range("A6:D6").Select 'als Kopfzeile markieren - nur für Optik
Sheets("Data").Select
Dim iRowLastUsed As Integer
'iRowLastUsed = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
'ActiveSheet.Rows(iRowLastUsed + 1).Select
Dim iActiveRow As Integer
Dim CW
'Dim ProductGroup As String
'ProductGroup = "ACR"
For Each e In ProductGroup
iRowLastUsed = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
For i = 0 To offset
iActiveRow = iRowLastUsed + 1 + i * 3
Cells(iActiveRow, 1).Select
CW = week + i
If (CW < 10) Then
sWeek = year & "-0" & CW
Else
sWeek = year & "-" & CW
End If
'PRF
ActiveCell.offset(0, 0) = sWeek
ActiveCell.offset(0, 1) = 8600000000#
ActiveCell.offset(0, 2) = "BGR Dummy"
ActiveCell.offset(0, 3) = e
ActiveCell.offset(0, 4) = 0
ActiveCell.offset(0, 5) = 0
ActiveCell.offset(0, 6) = 0
ActiveCell.offset(0, 7) = 100
ActiveCell.offset(0, 8) = 100
ActiveCell.offset(0, 9) = 0.9
ActiveCell.offset(0, 10) = csPRF
'ASS
ActiveCell.offset(1, 0) = sWeek
ActiveCell.offset(1, 1) = 8700000000#
ActiveCell.offset(1, 2) = "BGR Assembly"
ActiveCell.offset(1, 3) = e
ActiveCell.offset(1, 4) = 0
ActiveCell.offset(1, 5) = 0
ActiveCell.offset(1, 6) = 0
ActiveCell.offset(1, 7) = 100
ActiveCell.offset(1, 8) = 100
ActiveCell.offset(1, 9) = 0.9
ActiveCell.offset(1, 10) = csASS
'FT2
ActiveCell.offset(2, 0) = sWeek
ActiveCell.offset(2, 1) = 8700000000#
ActiveCell.offset(2, 2) = "OSR Dummy"
ActiveCell.offset(2, 3) = e
ActiveCell.offset(2, 4) = 0
ActiveCell.offset(2, 5) = 0
ActiveCell.offset(2, 6) = 0
ActiveCell.offset(2, 7) = 100
ActiveCell.offset(2, 8) = 100
ActiveCell.offset(2, 9) = 0.9
ActiveCell.offset(2, 10) = csFT2
'Zeilen formatieren
Rows(7).Select
Selection.Copy
Rows(iActiveRow).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Rows(iActiveRow + 1).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Rows(iActiveRow + 2).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Next i
Next e
End Sub
'2009-11-30
Function AddStatistik()
Sheets("Pivot").Select
Range("A10").Select
ActiveCell.offset(1, 5) = "PRF target"
ActiveCell.offset(1, 6) = "PRF yield"
ActiveCell.offset(1, 7) = "PRF 15w average"
ActiveCell.offset(1, 8) = "PRF diagram"
ActiveCell.offset(17, 6) = 0.88
For i = 0 To 15
Dim j
j = i + 2 + 10
ActiveCell.offset(i + 2, 5) = 0.97
Dim sTerm1 As String: Dim sTerm2 As String: Dim sTerm3 As String
sTerm1 = "IF(B" & j & "=0,0,(B" & j & "-C" & j & ")/B" & j & ")"
sTerm2 = "1"
sTerm3 = "1"
Dim sFormel As String
sFormel = "=" & sTerm1 & "*" & sTerm2 & "*" & sTerm3
ActiveCell.offset(i + 2, 6).Formula = sFormel
sFormel = "=G27"
ActiveCell.offset(i + 2, 7).Formula = sFormel
ActiveCell.offset(i + 2, 8).Formula = "=G" & j
Next i
Range("A35").Select
ActiveCell.offset(1, 5) = "FT2 target"
ActiveCell.offset(1, 6) = "FT2 yield"
ActiveCell.offset(1, 7) = "FT2 15w average"
ActiveCell.offset(1, 8) = "FT2 diagram"
ActiveCell.offset(17, 6) = 0.88
For i = 0 To 15
j = i + 2 + 35
ActiveCell.offset(i + 2, 5) = 0.97
sTerm1 = "IF(B" & j & "=0,0,(B" & j & "-C" & j & ")/B" & j & ")"
sTerm2 = "1"
sTerm3 = "1"
sFormel = "=" & sTerm1 & "*" & sTerm2 & "*" & sTerm3
ActiveCell.offset(i + 2, 6).Formula = sFormel
sFormel = "=G52"
ActiveCell.offset(i + 2, 7).Formula = sFormel
ActiveCell.offset(i + 2, 8).Formula = "=G" & j
Next i
'Spalten formatieren
Columns(6).Copy
Columns(7).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Columns(8).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("F:I").NumberFormat = "0.00"
Range("A3:C3").Select 'als Kopfzeile markieren - nur für Optik
End Function
Sub AddStatistikCode()
Dim CodeModuleBook As String
'CodeModuleBook = "Trend_KW03-17_HYC.xls"
CodeModuleBook = ActiveWorkbook.Name
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Set VBCodeMod = Workbooks(CodeModuleBook).VBProject. _
VBComponents("Tabelle3").CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)" & VBA.Chr(13) & _
" UpdateStatistik" & VBA.Chr(13) & _
"End Sub" & VBA.Chr(13)
End With
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Sub UpdateStatistik()" & VBA.Chr(13) & _
" Range(Cells(12, 7), Cells(26, 7)).Select" & VBA.Chr(13) & _
" For Each e In Selection" & VBA.Chr(13) & _
" e.Activate" & VBA.Chr(13) & _
" If (e.Value = 0) Then" & VBA.Chr(13) & _
" ActiveCell.offset(0, 2) = Null" & VBA.Chr(13) & _
" Else" & VBA.Chr(13) & _
" ActiveCell.offset(0, 2) = e.Value" & VBA.Chr(13) & _
" End If" & VBA.Chr(13) & _
" Next e" & VBA.Chr(13) & _
" Range(Cells(37, 7), Cells(51, 7)).Select" & VBA.Chr(13) & _
" For Each e In Selection" & VBA.Chr(13) & _
" e.Activate" & VBA.Chr(13) & _
" If (e.Value = 0) Then" & VBA.Chr(13) & _
" ActiveCell.offset(0, 2) = Null" & VBA.Chr(13) & _
" Else" & VBA.Chr(13) & _
" ActiveCell.offset(0, 2) = e.Value" & VBA.Chr(13) & _
" End If" & VBA.Chr(13) & _
" Next e" & VBA.Chr(13) & _
" Range(Cells(3, 1), Cells(3, 4)).Select" & VBA.Chr(13) & _
"End Sub" & VBA.Chr(13)
End With
End Sub
Sub AddZeilenCode()
Dim CodeModuleBook As String
CodeModuleBook = ActiveWorkbook.Name
Dim VBCodeMod As CodeModule
Dim LineNum As Long
Set VBCodeMod = Workbooks(CodeModuleBook).VBProject. _
VBComponents("Tabelle1").CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub Worksheet_SelectionChange(ByVal TargetRow As Range)" & VBA.Chr(13) & _
" Application.EnableEvents = False" & VBA.Chr(13) & _
" Rows(TargetRow.row).Select" & VBA.Chr(13) & _
" TargetRow.Activate" & VBA.Chr(13) & _
" Application.EnableEvents = True" & VBA.Chr(13) & _
"End Sub"
End With
End Sub
'2009-11-28
Function PivotPRF(sSourceData)
'aus Macro-Aufzeichnung abgeleitet
'Const sSourceData = "Test!R6C1:R85C9"
Const csSheet = "Image"
Dim sTablePRFDestination As String
sTablePRFDestination = csSheet & "!" & sTablePRFDestinationAddress
'Sheets.Add
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:=sSourceData).CreatePivotTable _
TableDestination:=sTablePRFDestination, _
TableName:="PivotTablePRF", _
DefaultVersion:=xlPivotTableVersion10
Sheets("Image").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTablePRF").PivotFields("Produktgruppe")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTablePRF").PivotFields("QTor")
.Orientation = xlPageField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTablePRF").PivotFields("KW")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTablePRF").AddDataField ActiveSheet.PivotTables( _
"PivotTablePRF").PivotFields("Produziert"), "Summe von Produziert", xlSum
ActiveSheet.PivotTables("PivotTablePRF").AddDataField ActiveSheet.PivotTables( _
"PivotTablePRF").PivotFields("Fehlerhaft"), "Summe von Fehlerhaft", xlSum
ActiveSheet.PivotTables("PivotTablePRF").AddDataField ActiveSheet.PivotTables( _
"PivotTablePRF").PivotFields("Ausschuss"), "Summe von Ausschuss", xlSum
'nächste Anweisung muss kann erst nach AddDataField kommen
With ActiveSheet.PivotTables("PivotTablePRF").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
'auf spezielle Page (QTor) einstellen
ActiveSheet.PivotTables("PivotTablePRF").PivotFields("QTor").CurrentPage = _
"PRF (ICT/ FPT / BST)"
'"Produkte & Systeme"
End Function
'2009-11-28
Function PivotProdukte(sSourceData)
'aus Macro-Aufzeichnung abgeleitet
'Const sSourceData = "Test!R6C1:R85C9"
Const csSheet = "Image"
Dim sTableFT2Destination As String
sTableFT2Destination = csSheet & "!" & sTableFT2DestinationAddress
'Sheets.Add
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:=sSourceData).CreatePivotTable _
TableDestination:=sTableFT2Destination, _
TableName:="PivotTableProdukte", _
DefaultVersion:=xlPivotTableVersion10
Sheets("Image").Select
'Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTableProdukte").PivotFields("Produktgruppe")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTableProdukte").PivotFields("QTor")
.Orientation = xlPageField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTableProdukte").PivotFields("KW")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTableProdukte").AddDataField ActiveSheet.PivotTables( _
"PivotTableProdukte").PivotFields("Produziert"), "Summe von Produziert", xlSum
ActiveSheet.PivotTables("PivotTableProdukte").AddDataField ActiveSheet.PivotTables( _
"PivotTableProdukte").PivotFields("Fehlerhaft"), "Summe von Fehlerhaft", xlSum
ActiveSheet.PivotTables("PivotTableProdukte").AddDataField ActiveSheet.PivotTables( _
"PivotTableProdukte").PivotFields("Ausschuss"), "Summe von Ausschuss", xlSum
'nächste Anweisung muss kann erst nach AddDataField kommen
With ActiveSheet.PivotTables("PivotTableProdukte").DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
'auf spezielle Page (QTor) einstellen
ActiveSheet.PivotTables("PivotTableProdukte").PivotFields("QTor").CurrentPage = _
"Produkte & Systeme"
'"PRF (ICT/ FPT / BST)"
'Pivot Tabelle formatieren
With Columns("B:D")
.ColumnWidth = 20
.HorizontalAlignment = xlCenter
.WrapText = False
End With
Range("A3:I4").Select
End Function
Sub AddDiagramPRF()
Const DiagramRange = "I11:I27"
Const ChartName = "ChartPRF"
Charts.Add
ActiveChart.Name = ChartName
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=Sheets("Pivot").Range(DiagramRange), _
PlotBy:=xlColumns
ActiveChart.Location WHERE:=xlLocationAsObject, Name:="Pivot"
End Sub
Sub AddDiagramFT2()
Const DiagramRange = "I36:I51"
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=Sheets("Pivot").Range(DiagramRange), _
PlotBy:=xlColumns
ActiveChart.Location WHERE:=xlLocationAsObject, Name:="Pivot"
End Sub
Function Diagramm_XY_ENH()
Const sDiagrammName As String = "ENH"
Const sDiagrammTitle As String = "Yield = f(t)"
Const iMinRpmSkalierung As Integer = 1000 'Umdr./min
Const iMinFlowSkalierung As Integer = 100 'lph
Const n_Header As String = "n(1/min)"
Const Q_Header As String = "Q_b(l/h)"
Const I_Header As String = "I(A)"
Diagramm_XY_ENH = True 'default
' ActiveSheet.ChartObjects.Delete 'default (alle Diagramme löschen); an dieser
' 'Stelle wichtig, da Benutzer ggf. ein Chart selektiert hat
ActiveSheet.Cells(1, 1).Activate
On Error Resume Next
ActiveSheet.ChartObjects(sDiagrammName).Delete 'falls vorhanden
On Error GoTo 0
Dim XY_Chart As ChartObject
Dim sChartTitle As String
Dim sPumpentyp As String: sPumpentyp = "Typ"
Dim lStartRow As Long: lStartRow = 12
Dim lStopRow As Long: lStopRow = ActiveCell(lStartRow, 6).CurrentRegion.Rows.Count: lStopRow = (lStopRow - 1) + (lStartRow - 1)
Dim sDatenbereich As String: sDatenbereich = Cells(lStartRow, 6).CurrentRegion.Address
Dim sStartDiagramm As String:
sStartDiagramm = Cells(lStartRow + 3, 2 + Cells(lStartRow, 1).CurrentRegion.Columns.Count).Address
'Default Diagrammgröße einstellen
intScaleDiaWidth = DiaWidth: intScaleDiaHeight = DiaHeight
'Skalierungswerte anhand des Maxiamalwertes der MAXIMUM-Zeile ermitteln
iY1AxesMaximumScale = WorksheetFunction.RoundUp(Range("F4"), 0) 'Ganzzahl
Application.ScreenUpdating = False
'2007-06-26
Dim bStatistik As Boolean
If Modul_Prüfstand.Test_Dateimerkmale_Prüfstand("Funktion (n)", "Mittelwert (1)", "Zähler (2)") Then
bStatistik = True
sStartDiagramm = "N2"
End If
Set XY_Chart = ActiveSheet.ChartObjects.Add(DiaLeft, DiaTop, DiaWidth, DiaHeight)
XY_Chart.Name = sDiagrammName
sChartTitle = sDiagrammTitle
Dim xCol As String: xCol = Find_Column(n_Header, sDatenbereich)
Dim S1Col As String: S1Col = Find_Column(Q_Header, sDatenbereich)
Dim S6Col As String: S6Col = Find_Column(I_Header, sDatenbereich)
Dim xHeaderRange As String: xHeaderRange = Find_Cell(n_Header, sDatenbereich)
Dim S1HeaderRange As String: S1HeaderRange = Find_Cell(Q_Header, sDatenbereich)
Dim S6HeaderRange As String: S6HeaderRange = Find_Cell(I_Header, sDatenbereich)
Dim xValueRange As String: xValueRange = xCol & lStartRow & ":" & xCol & lStopRow
Dim S1ValueRange As String: S1ValueRange = S1Col & lStartRow & ":" & S1Col & lStopRow 'Series 1 (Q)
Dim S6ValueRange As String: S6ValueRange = S6Col & lStartRow & ":" & S6Col & lStopRow 'Series 6 (I)
ActiveSheet.ChartObjects(sDiagrammName).Activate
'Set clsDiagramm.SVDO_Diagramm = ActiveSheet.ChartObjects(sDiagrammName).Chart
'Diagramm anordnen
With ActiveSheet.Shapes(sDiagrammName)
.Left = Range(sStartDiagramm).Left
.Top = Range(sStartDiagramm).Top
End With
'Datenreihen erstellen
With ActiveChart
.ChartType = xlXYScatter
.ChartArea.Interior.ColorIndex = 40 'hellrosa wie MINITAB Tool
'Textobjekt 1 (Bemerkung)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 100, 1, 100, 20)
.Name = "Bemerkung" 'Hinweis zur Lage des Sensors
.TextFrame.Characters.Text = "Pumpentyp: " & sPumpentyp
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Bemerkung").Select
With Selection
.AutoScaleFont = False
.Font.Size = 10
.Font.Bold = False
End With
On Error GoTo 0
'Textobjekt 2 (Hinweis)
With .Shapes.AddLabel(msoTextOrientationHorizontal, 3, 3, 200, 20)
.Name = "Hinweis"
If bStatistik Then
.TextFrame.Characters.Text = _
"ACHTUNG: wenn blaue Referenzlinie senkrecht = Pumpentyp unbekannt"
Else
.TextFrame.Characters.Text = _
"ACHTUNG: für Drehzahlgrenzendarstellung Statistikblock hinzufügen"
End If
.Width = 300
.Fill.ForeColor.SchemeColor = 2 'weiß
End With
ActiveChart.Shapes("Hinweis").Select
With Selection
.AutoScaleFont = False
.Font.Size = 8
.Font.Bold = False
.Font.ColorIndex = 3 'rot
End With
Dim iMarkerColor As Integer
iMarkerColor = Get_SVDO_Colors("n(1/min)")
'1. Datenreihe (Durchfluß Q)
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.AxisGroup = 1 'muss auf Primärachse
.Name = Range(S1HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S1ValueRange)
.MarkerBackgroundColorIndex = iMarkerColor
.MarkerForegroundColorIndex = iMarkerColor
.MarkerStyle = xlSquare
.MarkerStyle = xlCircle
'.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 4
.MarkerSize = 3
'.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S1HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
.LineStyle = xlNone
End With
End With
If bStatistik Then
Dim iYaxisAutoOldMin As Double
Dim iYaxisAutoOldMax As Double
iYaxisAutoOldMin = .Axes(xlValue, xlPrimary).MinimumScale
iYaxisAutoOldMax = .Axes(xlValue, xlPrimary).MaximumScale
Dim nLower As Double, nMean As Double, nUpper As Double
Dim ylower As Double, yMean As Double, yUpper As Double
nMean = Range("D4")
yMean = Range("I4")
Dim dSlope As Double, db As Double
dSlope = 1000# 'keine Steigung zu Indikation dass kein Typ bekannt (default)
'Achtung: ungleich 0, da sonst Laufzeitfehler bei Division
If VBA.InStr(1, sPumpentyp, "s") Then 'Sonderfall: Steigungsangabe in Typ
On Error Resume Next
dSlope = VBA.CCur(VBA.Mid(sPumpentyp, 2)) / 1000
On Error GoTo 0
End If
If VBA.InStr(1, sPumpentyp, "4.2") Then
dSlope = Get_Pumptype_Slope("4.2")
End If
If VBA.InStr(1, sPumpentyp, "4.42") Then
dSlope = Get_Pumptype_Slope("4.42")
End If
If VBA.InStr(1, sPumpentyp, "4.6") Then
dSlope = Get_Pumptype_Slope("4.6")
End If
'hier: kritische Programmierung
If VBA.InStr(1, sPumpentyp, "eta") Then 'ggf überschreibt 4.6 standard
dSlope = Get_Pumptype_Slope("4.6eta")
End If
If VBA.InStr(1, sPumpentyp, "5.7") Then
dSlope = Get_Pumptype_Slope("5.7")
End If
If VBA.InStr(1, sPumpentyp, "6.6") Then
dSlope = Get_Pumptype_Slope("6.6")
End If
If VBA.InStr(1, sPumpentyp, "8.6") Then
dSlope = Get_Pumptype_Slope("8.6")
End If
If VBA.InStr(1, sPumpentyp, "11") Or _
VBA.InStr(1, sPumpentyp, "11.0") Then
dSlope = Get_Pumptype_Slope("11.0")
End If
'y = ax + b wobei a = sSlope = bekannt
'Berechnung von b (Achsenabschnitt)
'b = y - ax
db = yMean - (dSlope * nMean)
'Berecnung von Unter- und Obergrenze mittels x-Wert
nLower = 1000
nUpper = 8000
ylower = (dSlope * nLower) + db
yUpper = (dSlope * nUpper) + db
'Berecnung von Unter- und Obergrenze mittels y-Wert
'y = ax + b wobei a=sSlope und b=db bekannt
'Berechnung von x (Drehzahlgrenzen)
'x = (y - b) / a
ylower = iYaxisAutoOldMin
yUpper = iYaxisAutoOldMax
nLower = (ylower - db) / dSlope
nUpper = (yUpper - db) / dSlope
'Spezielle Zellen benennen
Dim sASname As String: sASname = ActiveSheet.Name
ActiveWorkbook.Names.Add Name:="Steigung", _
RefersToR1C1:="='" & sASname & "'!R1C5"
ActiveWorkbook.Names.Add Name:="Achsenabschnitt", _
RefersToR1C1:="='" & sASname & "'!R1C6"
ActiveWorkbook.Names.Add Name:="REF_n_neg", _
RefersToR1C1:="='" & sASname & "'!R15C3"
ActiveWorkbook.Names.Add Name:="REF_n_pos", _
RefersToR1C1:="='" & sASname & "'!R15C5"
Range("D1:F2").Font.ColorIndex = 2 'weiss
Range("I1:I2").Font.ColorIndex = 2 'weiss
Range("D1").Formula = "=(I1-F1)/E1" 'untere Drehzahlgrenze
Range("D2").Formula = "=(I2-F2)/E2" 'obere Drehzahlgrenze
Range("F1").Formula = "=I4-(E1*D4)" 'Formel für Achsenabschnitt
'Range("E1").Formula = "=I4-(Steigung*D4)" 'Formel für Achsenabschnitt
'' Zellennamen erst ab XL2007 da, dann pro Sheet unterscheidbar
Range("F2").Formula = "=F1" 'Formel für Achsenabschnitt kopieren
Range("E1").Value = dSlope 'Wert für Steigung
Range("E2").Formula = "=E1" 'Wert für Steigung kopieren
Range("I1").Formula = "=I6-10"
Range("I2").Formula = "=I7+10"
'Formeln für automatische Diagrammaktualisierung in Tabelle eintragen
'Range("C16:H17").Font.ColorIndex = Range("C16").Font.Background
'und Daten unsichtbar machen
Range("C15:H17").Font.ColorIndex = 2 'weiss
'On Error GoTo 0
Range("D16").Formula = "=D4"
Range("D17").Formula = "=D16"
Range("G16").Formula = "=I6-10"
Range("G17").Formula = "=I7+10"
Range("C15").Value = 5 'Prozentwert
'Range("C16").Formula = "=D4*0.95"
Range("C16").Formula = "=D4*(1-C15/100)"
Range("C17").Formula = "=C16"
Range("F16").Formula = "=I6-10"
Range("F17").Formula = "=I7+10"
Range("E15").Value = 5 'Prozentwert
'Range("E16").Formula = "=D4*1.05"
Range("E16").Formula = "=D4*(1+E15/100)"
Range("E17").Formula = "=E16"
Range("H16").Formula = "=I6-10"
Range("H17").Formula = "=I7+10"
'
'2. Datenreihe (Trendline vom Mittelwert)
.SeriesCollection.NewSeries
With .SeriesCollection(2)
.AxisGroup = 1 'auf Primärachse
.Name = "Q (Trend)"
' .XValues = Array(nLower, nMean, nUpper)
' .Values = Array(ylower, yMean, yUpper)
.XValues = Range("D1:D2")
.Values = Range("I1:I2")
.MarkerBackgroundColorIndex = iMarkerColor
.MarkerForegroundColorIndex = iMarkerColor
' .MarkerStyle = xlSquare
' .MarkerStyle = xlCircle
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 4
.MarkerSize = 3
'.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = 5 'Blau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
End With
End If
If bStatistik Then
'3. Datenreihe (Referenzdrehzahl)
.SeriesCollection.NewSeries
With .SeriesCollection(3)
.AxisGroup = 1 'auf Primärachse
.Name = "Ref n"
' .XValues = Array(nMean, nMean)
' .Values = Array(iYaxisAutoOldMin, iYaxisAutoOldMax)
' .XValues = Range(Cells(1, 4), Cells(2, 4)) 'liefert nur Einzelwerte
.XValues = Range("D16:D17")
.Values = Range("G16:G17")
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
With .Border
.ColorIndex = 9 'Braun
.Weight = xlHairline
.LineStyle = xlDash
End With
End With
'4. Datenreihe (Referenzdrehzahl -5%)
.SeriesCollection.NewSeries
With .SeriesCollection(4)
.AxisGroup = 1 'auf Primärachse
.Name = "Ref n-5%"
' .XValues = Array(nMean * 0.95, nMean * 0.95)
' .Values = Array(iYaxisAutoOldMin, iYaxisAutoOldMax)
.XValues = Range("C16:C17")
.Values = Range("F16:F17")
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
With .Border
.ColorIndex = 9 'Braun
.Weight = xlHairline
.LineStyle = xlDot
End With
End With
'5. Datenreihe (Referenzdrehzahl +5%)
.SeriesCollection.NewSeries
With .SeriesCollection(5)
.AxisGroup = 1 'auf Primärachse
.Name = "Ref n+5%"
' .XValues = Array(nMean * 1.05, nMean * 1.05)
' .Values = Array(iYaxisAutoOldMin, iYaxisAutoOldMax)
.XValues = Range("E16:E17")
.Values = Range("H16:H17")
.MarkerStyle = xlNone 'Punktdarstellung ausschalten
With .Border
.ColorIndex = 9 'Braun
.Weight = xlHairline
.LineStyle = xlDot
End With
End With
'6. Datenreihe (Strom I)
'2007-09-05 hinzu
.SeriesCollection.NewSeries
With .SeriesCollection(6)
.AxisGroup = 2 'muss auf Sekundärachse
.Name = Range(S6HeaderRange)
.XValues = Range(xValueRange)
.Values = Range(S6ValueRange)
.MarkerBackgroundColorIndex = Get_SVDO_Colors("I(A)")
.MarkerForegroundColorIndex = Get_SVDO_Colors("I(A)")
.MarkerStyle = xlSquare
.MarkerStyle = xlCircle
'.MarkerStyle = xlNone 'Punktdarstellung ausschalten
.Smooth = False
.MarkerSize = 4
.MarkerSize = 3
'.MarkerSize = 2
.Shadow = False
With .Border
.ColorIndex = Get_SVDO_Colors(Range(S6HeaderRange))
.Weight = xlMedium
.LineStyle = xlContinuous
.LineStyle = xlNone
End With
End With
'Reihenfolge für Legende festlegen
With .ChartGroups(1)
'ACHTUNG: PlotOrder ändert SeriesCollection Reihenfolge
'Q_b Ref_n-5%
'Q_Trend Ref_n
'Ref_n Ref_n+5%
'Ref_n-5% Q_b
'Ref_n+5% Q_Trend
On Error Resume Next 'xl2007
.SeriesCollection(2).PlotOrder = 5
.SeriesCollection(1).PlotOrder = 4
.SeriesCollection(1).PlotOrder = 2
On Error GoTo 0
End With
End If
' Achsen formatieren
With .Axes(xlCategory, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "n [1/min]"
.AutoScaleFont = False
End With
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
Dim iMinCatScale As Integer: iMinCatScale = .MinimumScale - 100 'offset
Dim iMaxCatScale As Integer: iMaxCatScale = .MaximumScale
'Variablen hier einfacher zu debuggen
If (iMaxCatScale - iMinCatScale) < iMinRpmSkalierung Then
'Skalierung auf Mindesbreite einstellen
iMaxCatScale = iMinCatScale + iMinRpmSkalierung
.MinimumScale = iMinCatScale
.MaximumScale = iMaxCatScale
.MinorUnit = 100
.MajorUnit = 200
End If
' With .TickLabels
' .Alignment = xlCenter
' .Offset = 100
' .ReadingOrder = xlContext
' .Orientation = xlTickLabelOrientationAutomatic
' End With
End With
With .Axes(xlValue, xlPrimary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "Q [l/h]"
.AutoScaleFont = False
' .Size = 10
.Font.Size = 10 'xl2007
End With
.HasMajorGridlines = True
.HasMinorGridlines = False 'Keine Hilfslinien
'.MinimumScale = 0
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MaximumScale = iY1AxesMaximumScale
' .MajorUnit = iY1AxesMaximumScale / 10
'Max-Skalierung der Y1-Achse sichern für Übernahme Y2-Achse
iY2AxesMaximumScale = .MaximumScale 'Wert für 2. Achse sichern
Debug.Print iY2AxesMaximumScale
Dim iMinScale As Integer: iMinScale = .MinimumScale
Dim iMaxScale As Integer: iMaxScale = .MaximumScale
'Variablen hier einfacher zu debuggen
'iMinScale = (iMinScale / 10) * 10 'Runden auf Zehner
iMinScale = iMinScale / 10: iMinScale = iMinScale * 10 'Runden auf Zehner
iMinScale = iMinScale - 20 'offset
If (iMaxScale - iMinScale) < iMinFlowSkalierung Then
'Skalierung auf Mindesbreite einstellen
iMaxScale = iMinScale + iMinFlowSkalierung
.MinimumScale = iMinScale
.MaximumScale = iMaxScale
.MinorUnit = 10
.MajorUnit = 20
End If
.ScaleType = xlLinear
.DisplayUnit = xlNone
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y1-Achse
End With
If bStatistik Then
With .Axes(xlValue, xlSecondary)
.HasTitle = True
With .AxisTitle
.Characters.Text = "I [A]"
.AutoScaleFont = False
' .Size = 10
.Font.Size = 10 'xl2007
End With
'.MinimumScale = 0
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
iY2AxesMaximumScale = .MaximumScale 'Wert für 2. Achse sichern
Debug.Print iY2AxesMaximumScale
.ScaleType = xlLinear
.DisplayUnit = xlNone
.TickLabels.AutoScaleFont = False ' festes Format
.TickLabels.NumberFormat = "0.0" 'Zahlendarstellung Y2-Achse
.TickLabels.Font.Size = 10 'SVDO Größe
End With
End If 'bStatistik
.HasTitle = True
.ChartTitle.Text = sChartTitle
End With 'ActiveChart
'On Error Resume Next 'Fehler unterdrücken wenn z.B. keine Gridlines aktiv
With ActiveChart
'Diagramfläche
With .ChartArea
.Select
'Keine Änderungen
End With
'DiagrammTitel
With .ChartTitle
.AutoScaleFont = False
.Font.Size = 12
.Font.Bold = True
.Left = 0
.Top = 0
End With
'Zeichnungsfeld
With .PlotArea
.Interior.ColorIndex = xlAutomatic 'i.d.R Weiß
.Left = 20 'Platz lassen für Y-Achsenbezeichnung
.Top = 25 'Platz lassen für Diagrammtitel (fett)
.Height = 400 - 120 - 10 - 10
' .Width = 600 - 300 'Rand lassen
.Width = 600 - 320 'Rand größer wegen Stromachse hinzu
End With
'X-Achse
With .Axes(xlCategory)
.HasMajorGridlines = True
.HasMinorGridlines = True
.CrossesAt = 0
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.TickLabels.NumberFormat = "0" 'Spannung
' .TickLabelSpacing = 1
' .TickMarkSpacing = 1
' .MajorUnit = 1
' .MinorUnit = 0.5
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
' .AxisBetweenCategories = True
.ReversePlotOrder = False
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
With .MinorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
'Grenzbedingung
If .MinimumScale < 0 Then
.MinimumScale = 0
End If
End With
'Y1-Achse (Primary-Axes)
With .Axes(xlValue, xlPrimary)
.TickLabels.NumberFormat = "0" 'Zahlendarstellung Y-Achse
.TickLabels.AutoScaleFont = False 'Größe nicht frei scalieren
.TickLabels.Font.Size = 10
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
' .MajorUnit = 20
' .MinorUnit = 10
.MajorTickMark = xlOutside
.MinorTickMark = xlOutside
With .MajorGridlines.Border
.ColorIndex = 15 '15=hellstes grau
.Weight = xlHairline
.LineStyle = xlContinuous
End With
' With .MinorGridlines.Border
' .ColorIndex = 15 '15=hellstes grau
' .Weight = xlHairline
' .LineStyle = xlContinuous
' End With
'Grenzbedingung
If .MinimumScale < 0 Then
.MinimumScale = 0
End If
End With
On Error GoTo 0
'Legende
With .Legend
.Position = xlLegendPositionBottom
.AutoScaleFont = False
.Font.Size = 8
.Left = 10
.Top = DiaHeight - 30
.Width = DiaWidth - 25
' If XLVER = 12 Then
' .Format.Fill.BackColor.SchemeColor = 2 'xl2007
' .Format.Line.BackColor.SchemeColor = 3 'xl2007
' End If
End With
.HasLegend = True
End With 'ActiveChart
ActiveSheet.Shapes("QI_fn").Placement = xlFreeFloating 'd.h. unabhängig vom Autofilter
ActiveSheet.Range("B4").Select
ActiveWindow.Zoom = 85
Application.ScreenUpdating = True
End Function
Attribute VB_Name = "Modul_IRIS_Report"
'(c) 2010, Michael Gries
'Erstellung: 2010-12-29 (Hypercom)
'Letzte Änderung: 2012-02-25
'
Const csMsgBoxTitel = "Hypercom: Modul_IRIS_REPORT"
Const csPrivotSheetName = "IRIS report pivot"
Const csCognos_IRIS_Id1 = "DEFECT_CODE"
Const csCognos_IRIS_Id2 = "REPAIR_CODE"
Const csCognos_IRIS_Id3 = "CUSTOMER_NUMBER" 'xlWhole beachten wegen CUSTOMER_NUMBER_DISPLAY
Dim lNumberOfShippingDateRows As Long
'
'2012-02-25 first draft
'Amdocs report modified for IRIS Code generation
Sub AmdocsReports_IRIS_Pivot_WN()
If Cognos_Data_Found("Problem Found", "Incoming Unit Part Number", "Incoming Unit Serial Number") Then
'MsgBox ("Valid IRIS data found")
If Copy_Sheet("IRIS report internal") Then
Range("A1").Select
Application.ScreenUpdating = False
Call Add_Column_IRISCode_Defect
Call Add_Column_IRISCode_Condition
' Call Delete_RowsWithoutContent("SERIAL_NUMBER")
' Call Format_YearMonthDay("RECEIPT_DATE")
' Call Format_YearMonthDay("SHIPPING_DATE")
' Call Add_Column_RepairDays("RECEIPT_DATE", "SHIPPING_DATE")
' Call Validate_RepairCode
' Call Clear_Column_Content("MATERIAL_NUMBER", 1) 'Header offset=2
' Call Validate_MaterialNumber_KEBA
' Call Validate_MaterialDescription_KEBA
' Call Add_Column_DefectCodeName
' Call Add_Column_RepairCodeName
' Call Add_Column_SparePartName
' Call Add_Column_ComplaintNumber
' Application.ScreenUpdating = True
' Call Add_Column_Month("SHIPPING_DATE", "MONTH")
' Call Add_Column_CustomerName
' Call Add_Content_SectionCode
' Call Add_Column_MostOftenReplacedParts '2011-02-13 MORP - von Mapping_SparePartNumber abhängig
' Call Delete_Column("CUSTOMER_ORDER_NUMBER")
' Call Move_Column("SERIAL_NUMBER", "WARRANTY")
' Call Format_Report
Call Delete_Column("Ship to Address")
Call Delete_Column("Outgoing Unit Serial Number")
Call Delete_Column("Outgoing Unit Part Number")
Call Delete_Column("Outgoing Part Num Description")
Call Rename_Column("Incoming Unit Serial Number", "SERIAL_NUMBER")
Call Rename_Column("Site Name", "CUSTOMER_NAME")
Call Rename_Column("Ship to Zip", "SHIPPING_DATE")
Call Rename_Column("Ship to City", "REPAIR_CODE")
Call Rename_Column("Package Id", "REPAIR_CODE_NAME")
Call Rename_Column("Spare Parts Used", "DEFECT_CODE")
Call Rename_Column("Part Number Desc", "DEFECT_CODE_NAME")
Call Rename_Column("Part Number", "SPARE_PART_NUMBER")
Call Rename_Column("Incoming Unit Part Number", "REFERENCE2")
Call Rename_Column("Incoming Part Num Description", "REFERENCE3")
Range("A1").Select
Call Set_AutofilterCognosType
Call Add_Pivottable_IRIS
Call Add_PivotChart_IRIS("IRIS-Code report - WN")
Else
End If
End If
End Sub
'2011-05-22 first draft
'2011-06-05 update Chart, arrange columns, new mappings
Sub CognosReports_IRIS_Code_KEBA()
If Cognos_Data_Found("DEFECT_CODE", "REPAIR_CODE", "CUSTOMER_NUMBER") Then
'MsgBox ("Valid IRIS data found")
If Copy_Sheet("IRIS report internal") Then
Range("A1").Select
Call Delete_ReportDateLine
Application.ScreenUpdating = False
Call Delete_RowsWithoutContent("SERIAL_NUMBER")
Call Format_YearMonthDay("RECEIPT_DATE")
Call Format_YearMonthDay("SHIPPING_DATE")
Call Add_Column_RepairDays("RECEIPT_DATE", "SHIPPING_DATE")
Call Validate_RepairCode
Call Clear_Column_Content("MATERIAL_NUMBER", 1) 'Header offset=2
Call Validate_MaterialNumber_KEBA
Call Validate_MaterialDescription_KEBA
Call Add_Column_DefectCodeName
Call Add_Column_RepairCodeName
Call Add_Column_SparePartName
Call Add_Column_ComplaintNumber
Application.ScreenUpdating = True
Call Add_Column_Month("SHIPPING_DATE", "MONTH")
Call Add_Column_CustomerName
Call Add_Content_SectionCode
Call Add_Column_MostOftenReplacedParts '2011-02-13 MORP - von Mapping_SparePartNumber abhängig
Call Delete_Column("CUSTOMER_ORDER_NUMBER")
Call Delete_Column("REF_NUM_1")
Call Delete_Column("ENGINEER_CODE")
Call Delete_Column("REF_NUM_3")
Call Delete_Column("CHANGE")
Call Delete_Column("REVISION_LEVEL_NEW")
Call Delete_Column("VERSION")
Call Delete_Column("SECTION CODE")
Call Delete_Column("CODE_VERSION")
Call Delete_Column("MANUFACTURER")
Call Delete_Column("DEBITORS")
Call Delete_Column("CREDITORS")
Call Delete_Column("REPAIR_ID")
Call Delete_Column("REPAIR_PRICE")
Call Delete_Column("REPAIR_CENTER_NAME")
Call Delete_Column("YIELD_RATE")
Call Delete_Column("COMMENT")
Call Delete_Column("PROJECT_NAME")
Call Delete_Column("CUSTOMER_NUMBER_DISPLAY")
Call Move_Column("SERIAL_NUMBER", "WARRANTY")
Call Format_Report
Call Set_AutofilterCognosType
Call Add_Pivottable_IRIS
Call Add_PivotChart_IRIS("IRIS-Code report - KEBA")
Else
End If
End If
End Sub
'2011-06-09 update based on basic CognosReports_IRIS_Code() created 2010-12-29
Sub CognosReports_IRIS_Code_WN()
If Cognos_Data_Found("DEFECT_CODE", "REPAIR_CODE", "CUSTOMER_NUMBER") Then
'MsgBox ("Valid IRIS data found")
If Copy_Sheet("IRIS report WN internal") Then
Range("A1").Select
Call Delete_ReportDateLine
Application.ScreenUpdating = False
Call Delete_RowsWithoutContent("SERIAL_NUMBER")
Call Add_Column_RepairDays("RECEIPT_DATE", "SHIPPING_DATE")
Call Format_YearMonthDay("RECEIPT_DATE")
Call Format_YearMonthDay("SHIPPING_DATE")
Call Validate_RepairCode
Call Add_Column_DefectCodeName
Call Add_Column_RepairCodeName
Call Add_Column_SparePartName
Application.ScreenUpdating = True
Call Add_Column_Month("SHIPPING_DATE", "MONTH")
Call Add_Column_CustomerName
Call Add_Content_SectionCode
Call Add_Column_MostOftenReplacedParts '2011-02-13 MORP - von Mapping_SparePartNumber abhängig
'Call Delete_Column("CUSTOMER_ORDER_NUMBER")
Call Delete_Column("REF_NUM_1")
Call Delete_Column("ENGINEER_CODE")
Call Delete_Column("REF_NUM_3")
'Call Delete_Column("CHANGE")
'Call Delete_Column("REVISION_LEVEL_NEW")
'Call Delete_Column("VERSION")
'Call Delete_Column("SECTION CODE")
'Call Delete_Column("CODE_VERSION")
'Call Delete_Column("MANUFACTURER")
'Call Delete_Column("DEBITORS")
'Call Delete_Column("CREDITORS")
Call Delete_Column("YIELD_RATE")
'Call Delete_Column("REPAIR_ID")
Call Delete_Column("REPAIR_PRICE")
'Call Delete_Column("REPAIR_CENTER_NAME")
'Call Delete_Column("COMMENT")
'Call Delete_Column("PROJECT_NAME")
'Call Delete_Column("CUSTOMER_NUMBER_DISPLAY")
Call Move_Column("HYPERCOM_ORDER_NUMBER", "WARRANTY")
Call Move_Column("HYPERCOM_ITEM_NUMBER", "WARRANTY")
Call Move_Column("HYPERCOM_ITEM_DESCRIPTION", "WARRANTY")
Call Clear_Column_Content("MATERIAL_NUMBER", 1)
Call Validate_MaterialNumber_WN
Call Header_Mapping_WN
Call Format_Report
Call Set_AutofilterCognosType
Call Add_Pivottable_IRIS
Call Add_PivotChart_IRIS("IRIS-Code report - Wincor Nixdorf")
Else
End If
End If
End Sub
'2011-07-10 update based on basic CognosReports_IRIS_Code() created 2010-12-29
Sub CognosReports_IRIS_Code()
Const csSheetNameInternal = "IRIS-Report Internal"
If Cognos_Data_Found("DEFECT_CODE", "REPAIR_CODE", "CUSTOMER_NUMBER") Then
If Copy_Sheet(csSheetNameInternal) Then
Range("A1").Select
Call Set_AutofilterCognosType
Call Delete_ReportDateLine
Call Delete_RowsWithoutContent("SERIAL_NUMBER")
Call Add_Column_RepairDays("RECEIPT_DATE", "SHIPPING_DATE")
Call Format_YearMonthDay("RECEIPT_DATE")
Call Format_YearMonthDay("SHIPPING_DATE")
Call Validate_RepairCode
Call Add_Column_DefectCodeName
Call Add_Column_RepairCodeName
Call Add_Column_CustomerName
Call Add_Content_SectionCode
Call Add_Column_SparePartName
Call Add_Column_MostOftenReplacedParts
Call Format_Report
Call Add_Pivottable_IRIS
Call Add_PivotChart_IRIS("IRIS-Code Report")
'Sheets(csSheetNameInternal).Select
Else
'None if copying of original ply fails
End If
End If
End Sub
'2010-12-29
'2011-02-13 Mapping MORP
Sub CognosReports_IRIS_Code_old()
If Cognos_Data_Found("DEFECT_CODE", "REPAIR_CODE", "CUSTOMER_NUMBER") Then
'MsgBox ("Valid IRIS data found")
If Copy_Sheet("IRIS report internal") Then
Range("A1").Select
Call Header_Mapping
Range("A2").Select
Call Set_AutofilterCognosType
Call Delete_ReportDateLine
Call Delete_RowsWithoutContent("SERIAL_NUMBER")
'Call Add_MarkDoubleSerialNumbers Sortierung derzeit noch fehlerhaft da nur eine Spalte
Call Format_YearMonthDay("L:M")
Call Copy_ColumnContent("HYPERCOM_ORDER_NUMBER", "REF_NUM_1") 'WN mapping: Reference1
Application.ScreenUpdating = False
Call Copy_ColumnContent("HYPERCOM_ITEM_NUMBER", "ENGINEER_CODE") 'WN mapping: Reference2
Call Copy_ColumnContent("HYPERCOM_ITEM_DESCRIPTION", "REF_NUM_3") 'WN mapping: Reference3
Call Copy_ColumnContent("CUSTOMER_NUMBER", "HYPERCOM_ORDER_NUMBER") 'WN mapping: CustomerNumber
Call Copy_ColumnContent("REPAIR_CENTER_NAME", "HYPERCOM_ITEM_NUMBER") 'WN mapping: RepairVendor
Call Add_Column_RepairDays("RECEIPT_DATE", "SHIPPING_DATE")
Call Validate_RepairCode
Call Validate_MaterialNumber
Call Add_Column_DefectCodeName
Call Add_Column_RepairCodeName
Application.ScreenUpdating = True
Call Add_Column_CustomerName
Call Add_Content_SectionCode
Call Clear_Column_Content("REPAIR_PRICE", 2) 'Header offset=2
Call Clear_Column_Content("REPAIR_CENTER_NAME", 2) 'Header offset=2
'Call Mapping_SparePartNumber
Call Add_Column_SparePartName
Call Add_Column_MostOftenReplacedParts '2011-02-13 MORP - von Mapping_SparePartNumber abhängig
Call Format_Report
Call Add_Pivottable
Sheets("IRIS report internal").Select
Else
End If
End If
End Sub
'2010-12-29
Function IRIS_Data_Found() As Boolean
IRIS_Data_Found = False 'default
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csCognos_IRIS_Identifier1: sFindRange = "A1:Z1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlPart)
sCriteria = csCognos_IRIS_Identifier2: sFindRange = "A1:Z1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlPart)
sCriteria = csCognos_IRIS_Identifier3: sFindRange = "AA1:AZ1"
Dim ID3: Set ID3 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole) 'xlWhole beachten
If Not ID1 Is Nothing And Not ID2 Is Nothing And Not ID3 Is Nothing Then
IRIS_Data_Found = True
Else
Const csReasons = "No valid IRIS code data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2011-01-11
Function Cognos_Data_Found(sID1 As String, sID2 As String, sID3 As String) As Boolean
Cognos_Data_Found = False 'default
Const csFindRange As String = "1:10" 'consider only first 10 rows
Dim ID1: Set ID1 = Range(csFindRange).Find(sID1, LookIn:=xlValues, LookAt:=xlWhole) 'xlWhole or xlPart
Dim ID2: Set ID2 = Range(csFindRange).Find(sID2, LookIn:=xlValues, LookAt:=xlWhole) 'xlWhole or xlPart
Dim ID3: Set ID3 = Range(csFindRange).Find(sID3, LookIn:=xlValues, LookAt:=xlWhole) 'xlWhole or xlPart
If Not ID1 Is Nothing And Not ID2 Is Nothing And Not ID3 Is Nothing Then
Cognos_Data_Found = True
Else
Const csReasons = "No valid Cognos Report data found for Identifier: "
Const csContact = "Contact: Michael Gries, -691"
Dim sIdentifier: sIdentifier = sID1 & ", " & sID2 & ", " & sID3
Dim sText: sText = csReasons & vbCr & sIdentifier & vbCr & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2010-12-29
Function Copy_Sheet(sSheetName As String) As Boolean
Copy_Sheet = False 'default
On Error Resume Next
Sheets(sSheetName).Delete 'falls schon existent
Sheets(csPrivotSheetName).Delete 'falls schon existent
On Error GoTo 0
Dim sActiveSheetname As String: sActiveSheetname = ActiveSheet.Name
Sheets(sActiveSheetname).Copy Before:=Sheets(1)
Sheets(1).Name = sSheetName
Sheets(1).Select
Copy_Sheet = True
ActiveWorkbook.Sheets(sSheetName).Tab.ColorIndex = 36 'hellgelb
End Function
'2011-01-22 abgeleitet von Makrosammlung_Gries.Set_Autofilter
Sub Set_AutofilterCognosType()
'2010-06-12 (original version see Set_Autofilter_Musterbau)
On Error GoTo LZF1004
With ActiveSheet
.AutoFilterMode = False 'Autofilter zurücksetzen
Dim iColor As Integer: iColor = Selection.Interior.ColorIndex
Dim lRow As Long
lRow = Selection.row
Selection.Rows.AutoFit
With .Rows(lRow)
.RowHeight = .RowHeight + 12
.VerticalAlignment = xlTop
'.AutoFilter 'liefert an dieser Stelle manchmal mehr Spalten
Dim iLastCol: iLastCol = .CurrentRegion.Columns.Count ' oder später von hinten nach xlLeft
End With
.Range(Cells(lRow, 1), Cells(lRow, iLastCol)).AutoFilter
If (iColor = xlNone) Then
With .Range(Cells(lRow, 1), Cells(lRow, iLastCol))
.Interior.ColorIndex = 24 'default Diagrammfüllfarbe
.Font.Bold = True
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 47
End With
End With
End If
'Fenster fixieren
With ActiveWindow
.SplitRow = lRow
.FreezePanes = True
End With
End With
GoTo Final
LZF1004:
'Laufzeitfehler 1004
'z.B. wenn leeres Blatt oder leere Zeile
Debug.Print "ERROR: ", Err.Number,
Dim sErrorReason
sErrorReason = "Gries.xla Laufzeitfehler" & vbCr & Selection.Address & vbCr & Err.Description
MsgBox (sErrorReason)
Final:
End Sub
'2011-01-12 abgeleitet von Makrosammlung_Gries.Formel_YearMonth()
'2011-01-16 erweitert um Spaltennamen für sSelection anstelle Rangeangebe z.B."A:B"
Sub Format_YearMonth(sSelection As String)
Cells.MergeCells = False 'wichtig da manche Reports mit verbundenen Zellen arbeiten
'und Selection dann teilweise nicht arbeitet (alles markiert)
If InStr(sSelection, ":") = 0 Then 'Spaltenname
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sSelection: sFindRange = "1:10"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
Columns(iColumn).Select
End If
Else
ActiveSheet.Range(sSelection).Select
End If
Dim iCol As Integer: Dim iRow As Long
Dim e: Dim eV
Dim sValue As String 'als String um Leerzellen zu erkennen
For Each e In Selection
iCol = e.Column: iRow = e.row: eV = e.Value
If (IsDate(eV)) Then
If (month(eV) < 10) Then
sValue = year(eV) & "-0" & month(eV)
Else
sValue = year(eV) & "-" & month(eV)
End If
e.Value = sValue
End If
Next e
Cells(1, iCol).Select 'Selection aufheben für ungewollte weitere formatierungen
End Sub
'2011-01-12 abgeleitet von Makrosammlung_Gries.Formel_YearMonthDay()
'2011-01-16 erweitert um Spaltennamen für sSelection anstelle Rangeangebe z.B."A:B"
Sub Format_YearMonthDay(sSelection As String)
Cells.MergeCells = False 'wichtig da manche Reports mit verbundenen Zellen arbeiten
'und Selection dann teilweise nicht arbeitet (alles markiert)
If InStr(sSelection, ":") = 0 Then 'Spaltenname
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sSelection: sFindRange = "1:1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
Columns(iColumn).Select
End If
Else
Range(sSelection).Select
End If
Dim iCol As Integer: Dim iRow As Long
Dim e: Dim eV
Dim sValue As String 'als String um Leerzellen zu erkennen
Dim sMonth As String 'Monat einstellig/zweistellig
Dim sDay As String 'Tag einstellig/zweistellig
For Each e In Selection
iCol = e.Column: iRow = e.row: eV = e.Value
If (IsDate(eV)) Then
If (Day(eV) < 10) Then
sDay = "-0" & Day(eV)
Else
sDay = "-" & Day(eV)
End If
If (month(eV) < 10) Then
sMonth = "-0" & month(eV)
Else
sMonth = "-" & month(eV)
End If
sValue = year(eV) & sMonth & sDay '& "Zusatz"
e.Value = sValue
e.NumberFormat = "yyyy-mm-dd"
End If
Next e
Cells(1, iCol).Select 'Selection aufheben für ungewollte weitere formatierungen
End Sub
'2011-01-01
Function Format_Report()
Cells.Columns.AutoFit
With Columns("F:F")
.ColumnWidth = 20
.HorizontalAlignment = xlLeft
End With
With Columns("G:G")
.ColumnWidth = 40
.HorizontalAlignment = xlLeft
End With
With Columns("S:S")
.ColumnWidth = 40
.HorizontalAlignment = xlLeft
End With
With Columns("U:U")
.ColumnWidth = 40
.HorizontalAlignment = xlLeft
End With
With Columns("AA:AA")
.ColumnWidth = 20
.HorizontalAlignment = xlLeft
End With
Cells.Rows.AutoFit
Cells(1, 1).Select
End Function
'2011-01-02
Function Delete_ReportDateLine()
Columns("A:A").Select
Dim lRowLastUsed As Long: lRowLastUsed = Selection(Rows.Count, 1).End(xlUp).row
lNumberOfShippingDateRows = lRowLastUsed ' golbale variable (falls andere Spalten Leerzellen enthalten
Dim Value As Variant: Value = Cells(lRowLastUsed, 1).Value
If IsDate(Value) Then
Rows(lRowLastUsed).Delete
End If
End Function
'2011-01-03 nur zu Testzwecken (Ermittlung PivotTable index)
Sub Debug_PivotTables()
ActiveSheet.PivotTables.Count
For Each e In PivotTables
Debug.Print PivotTables.Name
Next e
End Sub
'2011-01-01
Function Add_Pivottable_IRIS()
Const csTableName = "PivotTableIRIScode"
Dim sPivotTable: sPivotTable = ActiveSheet.Name
'Datenumfang für Pivottabelle bestimmen
Dim sPivotRange: sPivotRange = ActiveCell.CurrentRegion.Address
Dim sPivotCache: sPivotCache = sPivotTable & "!" & sPivotRange
'Pivottabellen spezifische Felder definieren
Dim sPivotFields
Dim sPivotFieldsTitle
Dim sPageField1
Dim sRowField1
sPivotFields = "SERIAL_NUMBER"
sPivotFieldsTitle = "# of Serial"
sPageField1 = "CUSTOMER_NAME"
sRowField1 = "SHIPPING_DATE"
'Pivottabelle hinzufügen
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:=sPivotCache).CreatePivotTable _
TableDestination:="", _
TableName:=csTableName, _
DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.Name = csPrivotSheetName
ActiveWorkbook.Sheets(csPrivotSheetName).Tab.ColorIndex = 40 'orange
'Pivotfelder hinzufügen
With ActiveSheet.PivotTables(csTableName)
'Datenfelder hinzufügen
.AddDataField .PivotFields(sPivotFields), sPivotFieldsTitle, xlCount
'Datenseiten hinzufügen
With .PivotFields(sPageField1)
.Orientation = xlPageField: .Position = 1
End With
' ab hier weitere Pivots ableiten und
' Datenreihen hinzufügen
'
' zunächst gewünschte Gesamtanzahl von Pivot-Tabellen kopieren (wegen Index)
' Abstand abhängig von Anzahl Datenreihen und ggf. Datenspalten
' (hier nur max. jeweils 2 Datenreihen, ohne Datenspalte)
'
' zweite PivotTabelle hinzukopieren
Columns("A:B").Copy
Columns("D:E").Insert (xlShiftRight)
' dritte PivotTabelle hinzukopieren
Columns("A:B").Copy
Columns("H:I").Insert (xlShiftRight)
' vierte PivotTabelle hinzukopieren
Columns("A:B").Copy
Columns("L:M").Insert (xlShiftRight)
'
'jetzt zu den einzelnen Tabellen die Datenreihen hinzufügen
'due to 3 times copying: 4 is PivoTableIndex in Column A:B
With ActiveSheet.PivotTables(4)
With .PivotFields("SHIPPING_DATE")
.Orientation = xlRowField
.Position = 1
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
End With
'due to 3 times copying: 3 is PivoTableIndex in Column D:E
With ActiveSheet.PivotTables(3)
With .PivotFields("REPAIR_CODE")
.Orientation = xlRowField
.Position = 1
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
With .PivotFields("REPAIR_CODE_NAME")
.Orientation = xlRowField
.Position = 2
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
End With
'due to 3 times copying: 2 is PivoTableIndex in Column H:I
With ActiveSheet.PivotTables(2)
With .PivotFields("DEFECT_CODE")
.Orientation = xlRowField
.Position = 1
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
With .PivotFields("DEFECT_CODE_NAME")
.Orientation = xlRowField
.Position = 2
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
End With
'due to 3 times copying: 1 is PivoTableIndex in Column L:M
With ActiveSheet.PivotTables(1)
With .PivotFields("SPARE_PART_NUMBER")
.Orientation = xlRowField
.Position = 1
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
With .PivotFields("REPAIR_CODE_NAME")
.Orientation = xlRowField
.Position = 2
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
End With
End With
Range("C2").Select 'markiert keine Pivot-Tabelle und blendet somit die Feldeigenschaften aus
End Function
'2010-12-29
'2011-01-21 Änderung auf Excel WorksheetFunction Days360()
Function Add_Column_RepairDays(sStartdate As String, sEndDate As String)
Const csColumnTitle = "REPAIR_DAYS"
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sStartdate: sFindRange = "A1:Z1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlPart)
sCriteria = sEndDate: sFindRange = "A1:Z1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlPart)
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Dim iColumn1 As Integer: iColumn1 = ID1.Column
Dim iColumn2 As Integer: iColumn2 = ID2.Column
Dim iColumn3 As Integer: iColumn3 = ID2.Column + 1
Columns(iColumn3).Insert (xlShiftRight)
With Cells(1, iColumn3)
.Value = csColumnTitle
.Interior.ColorIndex = 40 'orange
End With
Dim lRowLastUsed As Long: lRowLastUsed = Cells(1, iColumn1).End(xlDown).row
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
With Cells(iOffset + l, iColumn3)
Dim dStartDate As Date: dStartDate = Cells(iOffset + l, iColumn1)
Dim dEndDate As Date: dEndDate = Cells(iOffset + l, iColumn2)
'.value = Cells(iOffset + l, iColumn - 1) - Cells(iOffset + l, iColumn - 2)
Dim dDate: dDate = Application.WorksheetFunction.Days360(dStartDate, dEndDate, True)
If Not dDate < 0 Then
.Value = dDate
End If
.Font.ColorIndex = 55 'Hypercom blue
End With
Next l
With Columns(iColumn3)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid xxx_DATE data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2011-01-03
Function Add_MarkDoubleSerialNumbers()
'abgeleitet von Sub Makrosammlung_Gries.CognosReports_MarkDoubleSerialNumbers
'2010-12-25 Sortiert S/N und markiert dopplete in separater Spalte
Const csCriteria = "Serial"
Dim lRow As Long: Dim iColumn As Integer
Dim lRowLastUsed As Long
Columns("B").Select
Dim c: Set c = Selection.Find(csCriteria, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
'Debug.Print c.Address
lRow = c.row: iColumn = c.Column
lRowLastUsed = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
'Sortierung zuerst
'c.CurrentRegion.Select
Range(Cells(3, iColumn), Cells(lRowLastUsed, iColumn)).Select
Selection.Sort Key1:=Cells(lRow, iColumn), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Spalten kopieren
Columns(iColumn).EntireColumn.Select
Selection.Copy
Selection.Insert Shift:=xlToRight
Columns(iColumn + 1).EntireColumn.Select
Selection.ClearContents
With Cells(2, iColumn + 1)
.Interior.ColorIndex = Cells(1, iColumn + 1).Interior.ColorIndex
End With
With Cells(1, iColumn + 1)
.Value = "S/N mark"
.Interior.ColorIndex = 40 'orange
End With
Cells(lRow, iColumn + 1).Select
Dim sSN1 As String: Dim sSN2 As String
Dim sSNmark As String
Dim l As Long
For l = lRow + 1 To lRowLastUsed
sSN1 = Cells(l, iColumn)
sSN2 = Cells(l + 1, iColumn)
sSNmark = Cells(l, iColumn + 1)
If sSN1 = sSN2 Then
Select Case sSNmark
Case ""
Cells(l, iColumn + 1) = "1x"
Cells(l + 1, iColumn + 1) = "2x"
Case "2x"
Cells(l, iColumn + 1) = "2x"
Cells(l + 1, iColumn + 1) = "3x"
Case "3x"
Cells(l, iColumn + 1) = "3x"
Cells(l + 1, iColumn + 1) = "4x"
Case "4x"
Cells(l, iColumn + 1) = "4x"
Cells(l + 1, iColumn + 1) = "5x"
Case "5x"
Cells(l, iColumn + 1) = "5x"
Cells(l + 1, iColumn + 1) = "6x"
Case Else
Cells(l, iColumn + 1) = "unknown"
End Select
Else
Select Case sSNmark
Case ""
Cells(l, iColumn + 1) = "1x"
Cells(l + 1, iColumn + 1) = ""
Case "2x"
Cells(l, iColumn + 1) = "2x"
Cells(l + 1, iColumn + 1) = ""
Case "3x"
Cells(l, iColumn + 1) = "3x"
Cells(l + 1, iColumn + 1) = ""
Case "4x"
Cells(l, iColumn + 1) = "4x"
Cells(l + 1, iColumn + 1) = ""
Case "5x"
Cells(l, iColumn + 1) = "5x"
Cells(l + 1, iColumn + 1) = ""
Case Else
Cells(l, iColumn + 1) = "else unknown"
End Select
End If
Next l
End If
End Function
'2011-01-01
Function Add_Column_CustomerName()
Const csColumnTitle = "CUSTOMER_NUMBER"
Dim mapping As New VBA.Collection
'Mapping table according AA-21_Q-Reporting Erstellung IRIS-Code
mapping.Add "Hectronic", "74309"
mapping.Add "HÖFT & WESSEL", "74261"
mapping.Add "KEBA", "74316"
mapping.Add "KONTRON", "74396"
mapping.Add "PayLife", "75045"
mapping.Add "WN Service", "74327"
mapping.Add "WN China", "74202"
mapping.Add "WN Singapore", "169809"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = "CUSTOMER_NAME"
.Interior.ColorIndex = 40
End With
Dim lRowLastUsed As Long: lRowLastUsed = Cells(1, iColumn - 1).End(xlDown).row
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
sCriteria = Cells(iOffset + l, iColumn - 1).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn)
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2011-01-01
Function Add_Column_DefectCodeName()
Const csColumnTitle = "DEFECT_CODE"
Dim mapping As New VBA.Collection
'Mapping table according AA-21_Q-Reporting Erstellung IRIS-Code
mapping.Add "Software problem", "1"
mapping.Add "No problem found (set within spec)", "3"
mapping.Add "No problem found (customer misunderstanding)", "4"
mapping.Add "No problem found (local conditions)", "5"
mapping.Add "Unable to diagnose fault", "6"
mapping.Add "Customer misuse", "9"
mapping.Add "Losing data from memory", "11"
mapping.Add "Software setup problem", "14"
mapping.Add "Worn out (or general mechanical defect)", "A"
mapping.Add "Misoperating", "A1"
mapping.Add "Mechanically misaligned", "C"
mapping.Add "Deformed", "E"
mapping.Add "Picture tube, scratches or external damage", "G1"
mapping.Add "Open pattern", "U"
mapping.Add "Soldering", "W"
mapping.Add "Dirty / clogged", "B"
mapping.Add "Cut / broken", "D"
mapping.Add "Loose / off / stripped", "I"
mapping.Add "Foreign object", "M"
mapping.Add "Defective electrical component / module", "N"
mapping.Add "Short circuit (component)", "Q"
mapping.Add "Bad contact, connection", "T"
mapping.Add "Wrong component / module", "Y"
mapping.Add "Missing component, module", "Z"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = csColumnTitle & "_NAME"
.Interior.ColorIndex = 40
End With
'Dim lRowLastUsed As Long: lRowLastUsed = Cells(1, iColumn - 1).End(xlDown).row
'lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lNumberOfShippingDateRows - iOffset
sCriteria = Cells(iOffset + l, iColumn - 1).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn)
.Select
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2011-06-05
Function Add_Column_Month(sColumnTitle As String, csColumnTitle As String)
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn1 As Integer: iColumn1 = ID1.Column
Columns(iColumn1).Copy Destination:=Columns(iColumn1 + 1)
With Cells(1, iColumn1)
.Value = csColumnTitle
.Interior.ColorIndex = 40 'hellorange
End With
Call Format_YearMonth(csColumnTitle)
End If
End Function
'2012-02-25
Function Add_Column_IRISCode_Condition()
Const csColumnTitle = "Problem Found"
Const csColumnTitleOfAddedColumn = "CONDITION_CODE"
Dim mapping As New VBA.Collection
'Mapping table according http://www.iriscode.org/IrisCode.exe?Sid=.20110605230956656&action=file&name=pdf/EN_IRIS_03.12.22.pdf
'1 - Constantly
'2 - Intermittently
mapping.Add "1", "No Trouble Found" '"No problem found (set within spec)"
mapping.Add "1", "Keyboard failure" '"Defective electrical component / module"
mapping.Add "1", "B02-Mainboard Failure" '"Defective electrical component / module"
mapping.Add "1", "P01-Physical Damage" '"Deformed"
mapping.Add "2", "T01-Tamper-Soft" '"Unable to diagnose fault"
mapping.Add "2", "T02-Tamper-Hard" '"Unable to diagnose fault"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = csColumnTitleOfAddedColumn
.Interior.ColorIndex = 40
End With
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
sCriteria = Cells(iOffset + l, iColumn - 1).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn)
.Select
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2012-02-25
Function Add_Column_IRISCode_Defect()
Const csColumnTitle = "Problem Found"
Const csColumnTitleOfAddedColumn = "DEFECT_CODE"
Dim mapping As New VBA.Collection
'Mapping table according AA-21_Q-Reporting Erstellung IRIS-Code
mapping.Add "1", "Software problem"
mapping.Add "3", "No Trouble Found" '"No problem found (set within spec)"
mapping.Add "4", "No problem found (customer misunderstanding)"
mapping.Add "5", "No problem found (local conditions)"
mapping.Add "6", "T01-Tamper-Soft" '"Unable to diagnose fault"
mapping.Add "6", "T02-Tamper-Hard" '"Unable to diagnose fault"
mapping.Add "9", "Customer misuse"
mapping.Add "11", "Losing data from memory"
mapping.Add "14", "Software setup problem"
mapping.Add "A", "Worn out (or general mechanical defect)"
mapping.Add "A1", "Misoperating"
mapping.Add "C", "Mechanically misaligned"
mapping.Add "E", "P01-Physical Damage" '"Deformed"
mapping.Add "G1", "Picture tube, scratches or external damage"
mapping.Add "U", "Open pattern"
mapping.Add "W", "Soldering"
mapping.Add "B", "Dirty / clogged"
mapping.Add "D", "Cut / broken"
mapping.Add "I", "Loose / off / stripped"
mapping.Add "M", "Foreign object"
mapping.Add "N", "Keyboard failure" '"Defective electrical component / module"
mapping.Add "N", "B02-Mainboard Failure" '"Defective electrical component / module"
mapping.Add "Q", "Short circuit (component)"
mapping.Add "T", "Bad contact, connection"
mapping.Add "Y", "Wrong component / module"
mapping.Add "Z", "Missing component, module"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = csColumnTitleOfAddedColumn
.Interior.ColorIndex = 40
End With
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
sCriteria = Cells(iOffset + l, iColumn - 1).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn)
.Select
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2011-01-01
'2011-07-10 UsedRange changed
Function Add_Column_RepairCodeName()
Const csColumnTitle = "REPAIR_CODE"
Dim mapping As New VBA.Collection
'Mapping table according AA-21_Q-Reporting Erstellung IRIS-Code
mapping.Add "Software upgrade", "2"
mapping.Add "Product upgrade (on request)", "3"
mapping.Add "Replacement", "A"
mapping.Add "Resoldering", "D"
mapping.Add "Cleaning", "E"
mapping.Add "Repaired electrical parts", "G"
mapping.Add "Functional check", "L"
mapping.Add "Maintenance", "N"
mapping.Add "Specification measurement", "M"
mapping.Add "Refurbishing", "O"
mapping.Add "Product exchange (impossible to repair)", "S4"
mapping.Add "Return without repair", "Y"
mapping.Add "Product exchange", "Z"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = csColumnTitle & "_NAME"
.Interior.ColorIndex = 40
End With
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
sCriteria = Cells(iOffset + l, iColumn - 1).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn)
.Select
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2011-06-05
Function Add_Column_SparePartName()
Const csColumnTitle = "SPARE_PART_NUMBER"
Dim mapping As New VBA.Collection
'Mapping table according CEDEC IRIS code
mapping.Add "Rechargeable battery", "040"
mapping.Add "tbd.", "070"
mapping.Add "Mainboard", "100"
mapping.Add "GSM board", "120"
mapping.Add "SAM board", "140"
mapping.Add "tbd.", "200"
mapping.Add "PPI board", "250"
mapping.Add "Display", "400"
mapping.Add "Printer", "430"
mapping.Add "Housing", "450"
mapping.Add "Security Circuit", "460"
mapping.Add "Card Reader", "500"
mapping.Add "Component", "570"
mapping.Add "Software", "700"
mapping.Add "Software MCU", "710"
mapping.Add "Subcomponent", "750"
mapping.Add "Keyboard", "800"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = VBA.Left(csColumnTitle, 10) & "_NAME"
.Interior.ColorIndex = 40
End With
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
sCriteria = Cells(iOffset + l, iColumn - 1).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn)
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2011-03-08 for Rai Yesenski (during Scottsdale visit)
Function Mapping_MORP_Code()
Cells(1, 1).Select
Call Set_AutofilterCognosType
Call Add_Column_SparePartName
Call Add_Column_MostOftenReplacedParts
End Function
'2011-02-13 for Rai Yesenski Aggregate Report
Function Add_Column_MostOftenReplacedParts()
Const csColumnTitle = "SPARE_PART_NAME"
Dim mapping As New VBA.Collection
'Mapping table according Aggregate report
'NPF SP/CA TSP LCD Misc/comp Plastic CR/RFID Comm SW/FW PRTR KYPD
mapping.Add "NPF", "NFF"
mapping.Add "SP/CA", "Spillage"
mapping.Add "SP/CA", "Customer Abuse"
mapping.Add "SP/CA", "Vandalismn"
mapping.Add "TSP", "Touchscreen"
mapping.Add "LCD", "Display"
mapping.Add "Misc/comp", "Rechargeable battery"
mapping.Add "Misc/comp", "Mainboard"
mapping.Add "Misc/comp", "PWBA"
mapping.Add "Misc/comp", "GSM board"
mapping.Add "Misc/comp", "SAM board"
mapping.Add "Misc/comp", "PPI board"
mapping.Add "Misc/comp", "Security Circuit"
mapping.Add "Misc/comp", "Component"
mapping.Add "Misc/comp", "Subcomponent"
mapping.Add "Plastic", "Housing"
mapping.Add "CR/RFID", "Card Reader"
mapping.Add "CR/RFID", "RFID board"
mapping.Add "Comm", "Communication board"
mapping.Add "SW/FW", "Software"
mapping.Add "SW/FW", "Software MCU"
mapping.Add "PRTR", "Printer"
mapping.Add "KYPD", "Keypad"
mapping.Add "KYPD", "Keyboard"
'default
mapping.Add "Misc/comp", "Unknown Spare Part Number"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = "MORP"
.Interior.ColorIndex = 40
End With
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
sCriteria = Cells(iOffset + l, iColumn - 1).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn)
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2010-12-29
Function Add_Content_SectionCode()
Const csColumnTitle = "SECTION CODE"
Const csCode = "KBD"
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:Z2"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
Dim l As Long: Dim iOffset As Integer: iOffset = 2
For l = 1 To lRowLastUsed - iOffset
Cells(iOffset + l, iColumn).Value = csCode
Next l
End If
End Function
'2011-06-05
Function Add_Column_ComplaintNumber()
Const csColumnTitle = "CUSTOMER_NUMBER"
Dim mapping As New VBA.Collection
'Mapping table according KEBA
mapping.Add "NA", "NA"
mapping.Add "20000xxxx", "see 8D-Report"
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column + 1
Columns(iColumn).Insert (xlShiftRight)
With Cells(1, iColumn)
.Value = "MELDUNGS_NUMMER"
.Interior.ColorIndex = 24 'default Diagrammfüllfarbe
End With
Columns(iColumn + 1).Insert (xlShiftRight)
With Cells(1, iColumn + 1)
.Value = "ABSTELLMAßNAHME"
.Interior.ColorIndex = 24 'default Diagrammfüllfarbe
End With
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
lNumberOfShippingDateRows = lRowLastUsed 'global variable - valid for all column modifications
Dim l As Long: Dim iOffset As Integer: iOffset = 1
For l = 1 To lRowLastUsed - iOffset
With Cells(iOffset + l, iColumn)
.Value = "NA"
.Font.ColorIndex = 55 'Hypercom blue
End With
Next l
For l = 1 To lRowLastUsed - iOffset
sCriteria = Cells(iOffset + l, iColumn).Value
If IsInCollection(mapping, sCriteria) Then
With Cells(iOffset + l, iColumn + 1)
.Value = mapping(sCriteria)
.Font.ColorIndex = 55 'Hypercom blue
End With
End If
Next l
With Columns(iColumn)
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
.AutoFit
End With
Else
Const csReasons = "No valid customer data found"
Const csContact = "Contact: Michael Gries, -691"
Dim sText: sText = csReasons & vbCr & csContact
Dim sResult: sResult = MsgBox(sText, vbCritical, csMsgBoxTitel)
End If
End Function
'2012-02-25
Function Rename_Column(sColumnTitle1 As String, sColumnTitle2 As String)
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sColumnTitle1: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
Cells(1, iColumn) = sColumnTitle2
End If
End Function
'2011-06-05
Function Delete_Column(sColumnTitle As String)
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
Columns(iColumn).Delete
End If
End Function
'2011-06-05
Function Move_Column(sColumnTitle As String, sColumnBefore As String)
Dim sCriteria1 As String: Dim sCriteria2 As String: Dim sFindRange As String
sCriteria1 = sColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria1, LookIn:=xlValues, LookAt:=xlWhole)
sCriteria2 = sColumnBefore: sFindRange = "A1:AZ1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria2, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Dim iColumn1 As Integer: iColumn1 = ID1.Column
Dim iColumn2 As Integer: iColumn2 = ID2.Column
Columns(iColumn2).Insert
If iColumn2 < iColumn1 Then
Columns(iColumn1 + 1).Copy Destination:=Columns(iColumn2)
Columns(iColumn1 + 1).Delete
Else
Columns(iColumn1).Copy Destination:=Columns(iColumn2)
Columns(iColumn1).Delete
End If
End If
End Function
Function Delete_RowsWithoutContent(sColumnTitle As String)
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sColumnTitle: sFindRange = "A1:Z1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
Set UR = ActiveSheet.UsedRange
Dim lRowLastUsed As Long: lRowLastUsed = UBound(UR.Formula) 'Anzahl der Zeilen ermitteln
For l = lRowLastUsed To 1 Step -1 'Rückwärts wegen löschen
If IsEmpty(Cells(l, iColumn)) Then
Rows(l).Select
Rows(l).Delete
End If
Next l
Set UR = Nothing
End If
End Function
'2010-12-29
Function Clear_Column_Content(sColumnTitle As String, iOffset As Integer)
iOffset = iOffset + 1 'erste Zeile nach Header
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
Columns(iColumn).Select
Range(Cells(iOffset, iColumn), Cells(iOffset + lNumberOfShippingDateRows, iColumn)).ClearContents
End If
End Function
'2011-01-01
Function Validate_RepairCode()
Const csColumnTitle = "REPAIR_CODE"
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:Z1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
sCriteria = "DEFECT_CODE": sFindRange = "A1:Z1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Dim iColumn1 As Integer: iColumn1 = ID1.Column
Dim iColumn2 As Integer: iColumn2 = ID2.Column
Columns(iColumn1).Select
Dim lRowLastUsed As Long: lRowLastUsed = Cells(1, iColumn1).End(xlDown).row
Dim l As Long: Dim iOffset As Integer: iOffset = 2
Dim sRepairCode As String: Dim sDefectCode As String
For l = 1 To lNumberOfShippingDateRows - iOffset
sRepairCode = Cells(iOffset + l, iColumn1).Value
sDefectCode = Cells(iOffset + l, iColumn2).Value
If sRepairCode = "NA" Then 'NA - Not applicable I.e. no Oracle mapping performed
If sDefectCode = "3" Then
With Cells(iOffset + l, iColumn1)
.Value = "L" 'equals "Functional check" code
.Font.ColorIndex = 3 'red
End With
End If
End If
Next l
End If
End Function
'2011-05-22
Function Validate_MaterialNumber_KEBA()
Const csColumnTitle = "MATERIAL_NUMBER"
Const csWorkbookRef = "KEBA"
Const csMatrixNameD = "KEBA"
'
Dim sIRISsourcePly As String: sIRISsourcePly = ActiveSheet.Name
ThisWorkbook.Sheets(csWorkbookRef).Copy After:=ActiveWorkbook.Sheets(sIRISsourcePly)
ActiveWorkbook.Sheets(sIRISsourcePly).Activate
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:Z1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
sCriteria = "SERIAL_NUMBER": sFindRange = "A1:Z1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
sCriteria = "HYPERCOM_ITEM_NUMBER": sFindRange = "A1:AZ1"
Dim ID3: Set ID3 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Dim iColumn1 As Integer: iColumn1 = ID1.Column
Dim iColumn2 As Integer: iColumn2 = ID2.Column
Columns(iColumn1).Select 'zwecks Ansicht und Formatierung
Selection.NumberFormat = "00000"
Dim l As Long: Dim iOffset As Integer: iOffset = 1
Dim sColumn1data As String: Dim sColumn2data As String
For l = 1 To lNumberOfShippingDateRows - iOffset
Cells(iOffset + l, iColumn1).Select 'zwecks Ansicht
sColumn1data = Cells(iOffset + l, iColumn1).Value
sColumn2data = Cells(iOffset + l, iColumn2).Value
If sColumn1data = "" Then 'IsEmty() funktioniert nicht
If Not sColumn2data = "" Then
With Cells(iOffset + l, iColumn1)
.Select
'.value = "Formel" 'nur für Testzwecke
.Font.ColorIndex = 3 'red
Call Formel_Sverweis("AH", csMatrixNameD, 2)
End With
End If
End If
Next l
End If
End Function
'2011-06-05
Function Validate_MaterialDescription_KEBA()
Const csColumnTitle = "HYPERCOM_ITEM_DESCRIPTION"
Const csWorkbookRef = "KEBA"
Const csMatrixNameD = "KEBA"
'
Dim sIRISsourcePly As String: sIRISsourcePly = ActiveSheet.Name
'ThisWorkbook.Sheets(csWorkbookRef).Copy After:=ActiveWorkbook.Sheets(sIRISsourcePly)
ActiveWorkbook.Sheets(sIRISsourcePly).Activate
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
sCriteria = "SERIAL_NUMBER": sFindRange = "A1:AZ1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Dim iColumn1 As Integer: iColumn1 = ID1.Column
Dim iColumn2 As Integer: iColumn2 = ID2.Column
Columns(iColumn1).Select 'zwecks Ansicht und Formatierung
Selection.NumberFormat = "00000"
Dim l As Long: Dim iOffset As Integer: iOffset = 2
Dim sColumn1data As String: Dim sColumn2data As String
For l = 1 To lNumberOfShippingDateRows - iOffset
Cells(iOffset + l, iColumn1).Select 'zwecks Ansicht
sColumn1data = Cells(iOffset + l, iColumn1).Value
sColumn2data = Cells(iOffset + l, iColumn2).Value
If sColumn1data = "" Then 'IsEmty() funktioniert nicht
If Not sColumn2data = "" Then
With Cells(iOffset + l, iColumn1)
.Select
'.value = "Formel" 'nur für Testzwecke
.Font.ColorIndex = 3 'red
Call Formel_Sverweis("AH", csMatrixNameD, 4)
End With
End If
End If
Next l
End If
End Function
'2011-01-03
Function Validate_MaterialNumber_WN()
Const csColumnTitle = "MATERIAL_NUMBER"
'
Dim sIRISsourcePly As String: sIRISsourcePly = ActiveSheet.Name
ThisWorkbook.Sheets("WN").Copy After:=ActiveWorkbook.Sheets(sIRISsourcePly)
ActiveWorkbook.Sheets(sIRISsourcePly).Activate
'
Dim sCriteria As String: Dim sFindRange As String
sCriteria = csColumnTitle: sFindRange = "A1:Z1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
sCriteria = "SERIAL_NUMBER": sFindRange = "A1:Z1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Dim iColumn1 As Integer: iColumn1 = ID1.Column
Dim iColumn2 As Integer: iColumn2 = ID2.Column
Columns(iColumn1).Select 'zwecks Ansicht und Formatierung
Selection.NumberFormat = "00000000000"
Dim l As Long: Dim iOffset As Integer: iOffset = 1
Dim sColumn1data As String: Dim sColumn2data As String
For l = 1 To lNumberOfShippingDateRows - iOffset
Cells(iOffset + l, iColumn1).Select 'zwecks Ansicht
sColumn1data = Cells(iOffset + l, iColumn1).Value
sColumn2data = Cells(iOffset + l, iColumn2).Value
If sColumn1data = "" Then 'IsEmty() funktioniert nicht
If Not sColumn2data = "" Then
With Cells(iOffset + l, iColumn1)
.Select
'.value = "Formel" 'nur für Testzwecke
.Font.ColorIndex = 3 'red
Call Formel_Sverweis("E", "WNxREF", 3)
End With
End If
End If
Next l
End If
End Function
'2011-01-03 update 2011-01-10, 2011-04-13
Sub Formel_Sverweis(sColumn As String, sMatrix As String, sSpalte As String)
'abgeleitet von Modul_Prüfstand.Formel_elektrischeLeistung
Dim e
For Each e In Selection
Dim lRow As Long: lRow = e.row
Dim iCol As Integer: iCol = e.Column
Dim sFormel As String
sFormel = "=" & _
"SVERWEIS(" & sColumn & lRow & ";" & sMatrix & ";" & sSpalte & ";FALSCH)"
e.FormulaLocal = sFormel
Next e
End Sub
'2011-01-01
Function Copy_ColumnContent(sColumnSource As String, sColumnDestination As String)
Dim sCriteria As String: Dim sFindRange As String
sCriteria = sColumnSource: sFindRange = "A1:AZ1"
Dim ID1: Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
sCriteria = sColumnDestination: sFindRange = "A1:AZ1"
Dim ID2: Set ID2 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing And Not ID2 Is Nothing Then
Dim iColumnSource As Integer: iColumnSource = ID1.Column
Dim iColumnDestination As Integer: iColumnDestination = ID2.Column
Columns(iColumnSource).Select
Dim lRowLastUsed As Long: lRowLastUsed = Cells(1, iColumnSource).End(xlDown).row
Dim l As Long: Dim iOffset As Integer: iOffset = 1
Dim sSourceData As String: Dim sDestinationData As String
For l = 1 To lRowLastUsed - iOffset
sSourceData = Cells(iOffset + l, iColumnSource).Value
With Cells(iOffset + l, iColumnDestination)
.Value = sSourceData
.Font.ColorIndex = 55 'Hypercom blue
End With
Next l
End If
End Function
Function Header_Mapping_WN()
'coding derived from module 'Modul_SQA'
Dim mapping As New VBA.Collection
'Mapping table Wincor Nixdorf
mapping.Add "PurchaseNumber", "CUSTOMER_ORDER_NUMBER"
mapping.Add "SerialNumber", "SERIAL_NUMBER"
mapping.Add "MaterialNumber", "MATERIAL_NUMBER"
mapping.Add "Reference1", "HYPERCOM_ORDER_NUMBER"
mapping.Add "Reference2", "HYPERCOM_ITEM_NUMBER"
mapping.Add "Reference3", "HYPERCOM_ITEM_DESCRIPTION"
mapping.Add "Warranty", "WARRANTY"
mapping.Add "RevisionChange", "CHANGE"
mapping.Add "Revision", "REVISION_LEVEL_NEW"
mapping.Add "NewVariant", "VERSION"
mapping.Add "IncommingDate", "RECEIPT_DATE"
mapping.Add "", "MONTH"
mapping.Add "OutgoingDate", "SHIPPING_DATE"
mapping.Add "ConditionCode", "CONDITION_CODE"
mapping.Add "MainsymptomCode", "MAIN_SYMPTOM_CODE"
mapping.Add "SectionCode", "SECTION CODE"
mapping.Add "DefectCode", "DEFECT_CODE"
mapping.Add "", "DEFECT_CODE_NAME"
mapping.Add "RepairCode", "REPAIR_CODE"
mapping.Add "", "REPAIR_CODE_NAME"
mapping.Add "CodeCharacter", "CODE_VERSION"
mapping.Add "ComponentNumber", "SPARE_PART_NUMBER"
mapping.Add "", "SPARE_PART_NAME"
mapping.Add "", "SPARE_PART_NÂME"
mapping.Add "", "MORP"
mapping.Add "Quantity", "QUANTITY"
mapping.Add "Manufacturer", "MANUFACTURER"
mapping.Add "DebitorNumber", "DEBITORS"
mapping.Add "ComponentName", "CREDITORS"
mapping.Add "RepairID", "REPAIR_ID"
mapping.Add "Unrepairable", "SCRAP"
mapping.Add "Worktime (m)", "COMMENT"
mapping.Add "RepairPrice", "PROJECT_NAME"
mapping.Add "Comment", "CUSTOMER_NUMBER_DISPLAY"
mapping.Add "ComponentLocation", "REPAIR_CENTER_NAME"
mapping.Add "CustomerNumber", "CUSTOMER_NUMBER"
mapping.Add "RepairVendor", "CUSTOMER_NAME"
'
'additonal Header row for mapping to be inserted
Rows(1).Copy
Rows(1).Insert (xlShiftDown)
'
Dim sCriteria As String: Dim ID1: Dim i
Dim sFindRange As String: sFindRange = "A1:AZ1"
For i = 1 To mapping.Count Step 1
sCriteria = Cells(1, i).Value
Set ID1 = Range(sFindRange).Find(sCriteria, LookIn:=xlValues, LookAt:=xlWhole)
If Not ID1 Is Nothing Then
Dim iColumn As Integer: iColumn = ID1.Column
If IsInCollection(mapping, sCriteria) Then 'Modul_IRIS_Code
With Cells(2, iColumn)
.Value = mapping(sCriteria)
.Interior.ColorIndex = 36 'hellgelb
End With
End If
End If
Next i
End Function
'http://www.vb-tec.de/collctns.htm
Public Function IsInCollection(ByRef col As Collection, ByRef elem As String) As Boolean
On Error Resume Next
If IsEmpty(col(elem)) Then: 'DoNothing
IsInCollection = (Err.Number = 0)
On Error GoTo 0
End Function
'2011-07-10 derived from Modul_Pivot adapted for IRIS report
Sub Add_PivotChart_IRIS(sChartTitle As String)
Const csRange = "L1"
Dim sPivotSheetName: sPivotSheetName = ActiveSheet.Name
Charts.Add
With ActiveChart
.SetSourceData Source:=Sheets(sPivotSheetName).Range(csRange)
.Location WHERE:=xlLocationAsNewSheet
.HasTitle = True 'wichtig
.ChartTitle.Characters.Text = sChartTitle
End With
Dim sPivotChartSheetName: sPivotChartSheetName = sPivotSheetName & "chart"
On Error Resume Next
Sheets(sPivotChartSheetName).Delete
On Error GoTo 0
ActiveSheet.Name = sPivotChartSheetName
ActiveSheet.Tab.ColorIndex = 35 'hellblau
End Sub