' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Steckbrief_erstellen()
Dim Datenbank As Workbook, Steckbrief As Workbook, objSh As Worksheet
Dim lngRow As Long
Dim strName As String
Dim objImg As Object
Dim lngCalc As Long, lngC As Long
'Makro in Aktiver Spalte ausführen
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
lngRow = ActiveCell.Row
'Please Wait Logo anzeigen
Ladebild.Show vbModeless
Application.Wait Now + TimeSerial(0, 0, 1)
'einblenden der Steckbrief Vorlage
Sheets("Vorlage Steckbrief").Visible = True
Set Datenbank = ActiveWorkbook
'Arbeitsmappen Check durchführen
Application.DisplayAlerts = False
If Dir("C:\temp\machine.xlsx") <> "" Then
Set Steckbrief = Workbooks.Open("C:\temp\machine.xlsx")
Datenbank.Activate
Sheets("Vorlage Steckbrief").Select
Sheets("Vorlage Steckbrief").Copy before:=Workbooks("machine.xlsx").Sheets(1)
Else
Datenbank.Activate
Sheets("Vorlage Steckbrief").Select
Sheets("Vorlage Steckbrief").Copy
ChDir "C:\Temp"
ActiveWorkbook.SaveAs Filename:="C:\Temp\machine.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Set Steckbrief = ActiveWorkbook
End If
Steckbrief.Sheets(1).Name = "neu" & lngRow
Set objSh = Steckbrief.Sheets("neu" & lngRow)
'Kopieren der Anlagendaten
With Datenbank.Sheets("Database")
'Bezeichnung
objSh.Cells(6, 2) = .Cells(lngRow, 3).Text & (" ") & .Cells(lngRow, 6).Text
'Country
objSh.Cells(11, 3) = .Cells(lngRow, 1).Text
'location
objSh.Cells(12, 3) = .Cells(lngRow, 2).Text
'machine
objSh.Cells(13, 3) = .Cells(lngRow, 3).Text
'classification
objSh.Cells(14, 3) = .Cells(lngRow, 4).Text
'kind of condition
objSh.Cells(15, 3) = .Cells(lngRow, 5).Text
'plant number
objSh.Cells(16, 3) = .Cells(lngRow, 6).Text
'adress
objSh.Cells(17, 3) = .Cells(lngRow, 7).Text
'contact
objSh.Cells(18, 3) = .Cells(lngRow, 8).Text
'inventory number
objSh.Cells(19, 3) = .Cells(lngRow, 10).Text
'place requirement
objSh.Cells(20, 3) = .Cells(lngRow, 12).Text
'year of manufacture
objSh.Cells(22, 3) = .Cells(lngRow, 13).Text
'advertising price
objSh.Cells(23, 3) = .Cells(lngRow, 15).Text
'connected load
objSh.Cells(24, 3) = .Cells(lngRow, 16).Text
'mech. kind of cleaning
'Datenbank.Activate
objSh.Cells(25, 3) = .Cells(lngRow, 35).Text
'characteristics
'charge
objSh.Range("B30") = .Cells(lngRow, 31).Value
'magnet
objSh.Range("C30") = .Cells(lngRow, 32).Value
'oil
objSh.Range("D30") = .Cells(lngRow, 33).Value
'filtration
objSh.Range("B32") = .Cells(lngRow, 34).Value
'flue
objSh.Range("C32") = .Cells(lngRow, 36).Value
'vakuum
objSh.Range("D32") = .Cells(lngRow, 37).Value
'bath
'bath 1
'chastener
objSh.Range("H13") = .Cells(lngRow, 39).Value
'concentration
objSh.Range("I13") = .Cells(lngRow, 40).Value
'volume
objSh.Range("J13") = .Cells(lngRow, 41).Value
'bath 2
'chastener
objSh.Range("H14") = .Cells(lngRow, 42).Value
'concentration
objSh.Range("I14") = .Cells(lngRow, 43).Value
'volume
objSh.Range("J14") = .Cells(lngRow, 44).Value
'bath 3
'chastener
objSh.Range("H15") = .Cells(lngRow, 45).Value
'concentration
objSh.Range("I15") = .Cells(lngRow, 46).Value
'volume
objSh.Range("J15") = .Cells(lngRow, 47).Value
'bath 4
'chastener
objSh.Range("H16") = .Cells(lngRow, 48).Value
'concentration
objSh.Range("I16") = .Cells(lngRow, 49).Value
'volume
objSh.Range("J16") = .Cells(lngRow, 50).Value
'bath 5
'chastener
objSh.Range("H17") = .Cells(lngRow, 51).Value
'concentration
objSh.Range("I17") = .Cells(lngRow, 52).Value
'volume
objSh.Range("J17") = .Cells(lngRow, 53).Value
'bath 6
'chastener
objSh.Range("H18") = .Cells(lngRow, 54).Value
'concentration
objSh.Range("I18") = .Cells(lngRow, 55).Value
'volume
objSh.Range("J18") = .Cells(lngRow, 56).Value
'bath 7
'chastener
objSh.Range("H19") = .Cells(lngRow, 57).Value
'concentration
objSh.Range("I19") = .Cells(lngRow, 58).Value
'volume
objSh.Range("J19") = .Cells(lngRow, 59).Value
'bath 8
'chastener
objSh.Range("H20") = .Cells(lngRow, 60).Value
'concentration
objSh.Range("I20") = .Cells(lngRow, 61).Value
'volume
objSh.Range("J20") = .Cells(lngRow, 62).Value
'component1
'objsh.Range("H23")=.Cells(lngRow, 28).value
'component2
'objsh.Range("I23")=.Cells(lngRow, 28).value
'Cycle Time1
objSh.Range("H24") = .Cells(lngRow, 17).Value
'Cycle Time2
objSh.Range("I24") = .Cells(lngRow, 21).Value
'washing Time1
objSh.Range("H25") = .Cells(lngRow, 18).Value
'washing Time2
objSh.Range("I25") = .Cells(lngRow, 22).Value
'parts per pallet1
objSh.Range("H26") = .Cells(lngRow, 19).Value
'parts per pallet2
objSh.Range("I26") = .Cells(lngRow, 23).Value
'number of pallet1
objSh.Range("H27") = .Cells(lngRow, 20).Value
'number of pallet2
objSh.Range("I27") = .Cells(lngRow, 24).Value
'general remarks
objSh.Range("H34") = .Cells(lngRow, 38).Value
'BILDER
'process-flow of component 1
Set objImg = getPicture(.Cells(lngRow, 63))
If Not objImg Is Nothing Then
objImg.Copy
objSh.Paste
objSh.Shapes(objImg.Name).Top = objSh.Cells(34, 3).Top + 1
objSh.Shapes(objImg.Name).Left = objSh.Cells(34, 3).Left
End If
'process-flow of component 2
Set objImg = getPicture(.Cells(lngRow, 64))
If Not objImg Is Nothing Then
objImg.Copy
objSh.Paste
objSh.Shapes(objImg.Name).Top = objSh.Cells(37, 3).Top + 1
objSh.Shapes(objImg.Name).Left = objSh.Cells(37, 3).Left
End If
'picture of component 1
Set objImg = getPicture(.Cells(lngRow, 65))
If Not objImg Is Nothing Then
objImg.Copy
objSh.Paste
objSh.Shapes(objImg.Name).Top = objSh.Cells(30, 8).Top + 1
objSh.Shapes(objImg.Name).Left = objSh.Cells(30, 8).Left
End If
'picture of component 2
Set objImg = getPicture(.Cells(lngRow, 66))
If Not objImg Is Nothing Then
objImg.Copy
objSh.Paste
objSh.Shapes(objImg.Name).Top = objSh.Cells(30, 9).Top + 1
objSh.Shapes(objImg.Name).Left = objSh.Cells(30, 9).Left
End If
'Anlage
Set objImg = getPicture(.Cells(lngRow, 67))
If Not objImg Is Nothing Then
objImg.Copy
objSh.Paste
objSh.Shapes(objImg.Name).Top = objSh.Cells(1, 4).Top + 1
objSh.Shapes(objImg.Name).Left = objSh.Cells(1, 4).Left
End If
End With
'verstecken der Steckbrief Vorlage
Datenbank.Activate
Sheets("Vorlage Steckbrief").Visible = xlVeryHidden
Datenbank.Sheets("Database").Activate
Datenbank.Save
'Ladebild ausblenden
Ladebild.Hide
' Benennen des Tabellenblattes
strName = Datenbank.Sheets("Database").Cells(lngRow, 3) & " " & Datenbank.Sheets("Database").Cells(lngRow, 6)
Do While SheetExist(strName, Steckbrief)
lngC = lngC + 1
strName = strName & " (" & lngC & ")"
Loop
objSh.Name = strName
'Steckbrief anzeigen
Steckbrief.Activate
Application.Goto objSh.Range("A1"), True
Steckbrief.Save
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'Steckbrief_erstellen'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set Datenbank = Nothing
Set Steckbrief = Nothing
Set objImg = Nothing
Set objSh = Nothing
End Sub
Public Function getPicture(rng As Excel.Range) As Object
Dim item As Object
For Each item In rng.Parent.Shapes
If item.TopLeftCell.Address = rng.Address Then
Set getPicture = item
Exit For
End If
Next
End Function
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function