Sub Import_Wibs(control As IRibbonControl)
Dim rZelle As Range, aUeberschr As Variant, aFunktion As Variant, _
aUmbenennen As Variant, aFormatirung As Variant, iIndx2 As Integer, iStart As Integer, _
iIndx As Integer, iSpalte As Integer, iLetzteZeile As Integer, izaehler As Integer, _
wAuftrag As Worksheet, wImport As Worksheet, wFunktion As Worksheet, _
sAuftragsnummer As String, sECSeditor As String, sGebeudeAdresse As String, _
sGebeudeAdresseId As String, sType As String, iLetzteSpalte As Integer, _
sBemerkung As String, bStatusBarState As Boolean, lCalcState As Long, _
bEventsState As Boolean, bDisplayPageBreakState As Boolean, bPrintCommunicationState As Boolean
bStatusBarState = Application.DisplayStatusBar
lCalcState = Application.Calculation
bEventsState = Application.EnableEvents
bDisplayPageBreakState = ActiveSheet.DisplayPageBreaks
bPrintCommunicationState = Application.PrintCommunication
aUeberschr = Array("POS_ID", "LOC_DN", "LOC_DN_OLD", "ROOM", "ROOM_OLD", "FLOOR", _
"FLOOR_OLD", "DESK", "DESK_OLD", "SID_HWADDRESS", "SID_HWADDRESS_OLD", "DISPLAY", _
"DISPLAY_OLD", "MAIN_BUILDIMG_ID")
aFunktion = Array("POS_ID", "SID_HWADDRESS", "ACCEPTED_BY_NAME", "PLATFORM", "ACC_PHO", _
"BUILDING_ADDRESS", "MAIN_BUILDIMG_ID", "ADD_H", "CHANGE_TYPE", "ORDERER_NAME", "ORD_PHO", _
"ORD_REMARK", "OWNER_NAME", "OWN_PHO", "O_DEL", "BUILDING_ID", "BUILDING_ID_OLD", "DATEW", _
"ENTRY_DATE", "MAC_PROD_TARGET", "TARGET_DATE", "T_DATE", "WISH_TARGET")
aUmbenennen = Array("", " ", "Nummer", "Nummer Alt", "Raum", "Raum Alt", "St.", _
"St. Alt", "Desk", "Desk Alt", "SID", "SID Alt", "Display", "Display Alt")
aFormatirung = Array("", "#.", " ### ## ##", " ### ## ##")
On Error GoTo Fehler
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
With Worksheets
.Add
.Add after:=Worksheets(2)
End With
Set wAuftrag = Worksheets(1)
Set wImport = Worksheets(2)
Set wFunktion = Worksheets(3)
With wImport
.Activate
.Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, _
FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name _
= "WibsImport"
Range("WibsImport").HorizontalAlignment = xlLeft
.Columns.EntireColumn.AutoFit
End With
With wImport.Rows(1)
For iIndx = 0 To UBound(aUeberschr)
Set rZelle = .Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then iSpalte = iSpalte + 1: _
wImport.Columns(rZelle.Column).Copy Destination:=wAuftrag.Columns(iSpalte)
Next iIndx
End With
iSpalte = 0
With wImport.Rows(1)
For iIndx = 0 To UBound(aFunktion)
Set rZelle = .Find(aFunktion(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then iSpalte = iSpalte + 1: _
wImport.Columns(rZelle.Column).Copy Destination:=wFunktion.Columns(iSpalte)
Next iIndx
End With
With wFunktion
.Activate
.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name _
= "nFunktion"
.Range("nFunktion").RemoveDuplicates Columns:=Array(3, 4, 5, 6, 7, 8, _
9, 10, 11, 12, 13, 14, 15, 16), Header:=xlYes
Range("B:V").HorizontalAlignment = xlLeft
sAuftragsnummer = .Range("N2").Value
sECSeditor = .Range("C2").Value
sGebeudeAdresse = .Range("F2").Value
If .Range("O2").Value = .Range("P2").Value Then sGebeudeAdresseIdOld = "": _
sGebeudeAdresseId = .Range("O2").Value Else sGebeudeAdresseId = _
.Range("O2").Value: sGebeudeAdresseIdOld = .Range("P2").Value
sBemerkung = .Range("K2").Value
sType = wFunktion.Range("H2").Value
End With
With wAuftrag
.Activate
ActiveWindow.DisplayHeadings = False
For iIndx = 1 To UBound(aUmbenennen)
Cells(1, iIndx) = aUmbenennen(iIndx)
Next iIndx
.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name _
= "Auftrag"
For iIndx = 1 To UBound(aFormatirung)
Cells.Columns(iIndx).NumberFormat = aFormatirung(iIndx)
Next iIndx
Columns(1).HorizontalAlignment = xlRight
Columns.EntireColumn.AutoFit
iLetzteZeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
iLetzteSpalte = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
iStart = 3
For iIndx = 2 To 12 Step 2
For iIndx2 = 2 To iLetzteZeile
If Cells(iIndx2, iIndx).Value = Cells(iIndx2, iStart).Value Then izaehler = izaehler + 1
Next iIndx2
izaehler = izaehler + 1
If izaehler = iLetzteZeile Then Columns(iStart).Hidden = True
iStart = iStart + 2
izaehler = 0
Next iIndx
For iIndx = 1 To 13
For iIndx2 = 2 To iLetzteZeile
If Cells(iIndx2, iIndx).Value = "" Then izaehler = izaehler + 1
Next iIndx2
izaehler = izaehler + 1
If izaehler = iLetzteZeile Then Columns(iIndx).Hidden = True
izaehler = 0
Next iIndx
iLetzteSpalte = iLetzteSpalte + 1
For iIndx = iLetzteSpalte To 16384
Columns(iIndx).Hidden = True
Next iIndx
End With
wAuftrag.Name = "Auftrag " & sAuftragsnummer
wImport.Name = "Import Wibs " & sAuftragsnummer
Application.PrintCommunication = False
With wAuftrag.PageSetup
.PrintTitleRows = "$1:$1"
.PrintArea = ""
.LeftHeader = "&""Calibri,Fett""&11" & "Auftragsnummer: " & _
sAuftragsnummer & Chr(10) & "ECS Editor: " & sECSeditor & _
vbTab & vbTab & vbTab & vbTab & "Type: " & sType
.CenterHeader = "&""Calibri,Fett""&11 " & sGebeudeAdresseId & _
" " & sGebeudeAdresseIdOld & " " & sGebeudeAdresse & Chr(10) & _
sBemerkung
.LeftMargin = Application.InchesToPoints(0.708661417322835)
.RightMargin = Application.InchesToPoints(0.708661417322835)
.TopMargin = Application.InchesToPoints(0.78740157480315)
.BottomMargin = Application.InchesToPoints(0.78740157480315)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
Aufraeumen:
Application.PrintCommunication = bPrintCommunicationState
Application.ScreenUpdating = True
Application.DisplayStatusBar = bStatusBarState
Application.Calculation = lCalcState
Application.EnableEvents = bEventsState
ActiveSheet.DisplayPageBreaks = bDisplayPageBreaksState
Exit Sub
Fehler:
MsgBox "Da war ein Fehler"
Resume Aufraeumen
End Sub