Hallo

bin neu hier im Forum und VBA Anfänger, habe mein erstes Makro Add-in gemacht.
Habe jetzt das Problem das es ziemlich langsam ist, was kann ich optimieren das es schneller wird?

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 ' Mappe Refresh aus
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  'Kopieren Text in Spalten
    .ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name _
    = "WibsImport" ' Erstelle Tabelle Wibs_Import
    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" ' Erstelle Tabelle Auftrag
    .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" ' Erstelle Tabelle Auftrag
    For iIndx = 1 To UBound(aFormatirung)
    Cells.Columns(iIndx).NumberFormat = aFormatirung(iIndx)
    Next iIndx
    'Range("B:N").HorizontalAlignment = xlLeft
    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 ' Umbennen Blatt 1
wImport.Name = "Import Wibs " & sAuftragsnummer ' Umbennen Blatt 2
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 'Chr(10)
    .CenterHeader = "&""Calibri,Fett""&11 " & sGebeudeAdresseId & _
    " " & sGebeudeAdresseIdOld & " " & sGebeudeAdresse & Chr(10) & _
    sBemerkung
   ' .RightHeader = ""
    .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
'    .PrintQuality = 600
    .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 ' Mappe Refresh ein
Application.DisplayStatusBar = bStatusBarState
Application.Calculation = lCalcState
Application.EnableEvents = bEventsState
ActiveSheet.DisplayPageBreaks = bDisplayPageBreaksState
Exit Sub
Fehler:
    MsgBox "Da war ein Fehler"
    Resume Aufraeumen
End Sub