Inputbox in Makro integrieren

Sub ASL_Sortieren_mit_Teileunterscheidung_VSC_PT_Teile()
' ASL_Sortieren_mit_Teileunterscheidung_VSC_PT_Teile Makro
'On Error GoTo Errorhandler
Dim Ende As Long
Ende = 3
Do Until Cells(Ende + 1, 1) = ""
Ende = Ende + 1
Loop
' msgbox ("letzte Zeile ist die Nr.  " & Ende)
Rows("1:1").Select
'Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.AutoFilter
Selection.Replace What:="IGNORE,", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("E2").Select
Cells.Replace What:="IGNORE,", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Rows("1:1").Select
Selection.RowHeight = 130
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Columns("A:CF").Select
Columns("A:CF").EntireColumn.AutoFit
Range("V6").Select
'Erste Spalte löschen und Ansicht einfrieren
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
ActiveWindow.FreezePanes = True
'Spalte "Teilebedarf" markieren,Zellen mit Wert finden, farbig markieren
Range("A1", "IV1").Select
For Each rngzelle In Selection
If rngzelle.Value = "Teilebedarf" Then
'rngZelle.Interior.ColorIndex = 6
rngzelle.EntireColumn.Select
End If
Next rngzelle
For Each rngzelle In Selection
If IsNumeric(rngzelle.Value) And Not IsEmpty(rngzelle.Value) Then
rngzelle.EntireRow.Interior.Color = vbYellow
Else
rngzelle.EntireRow.Interior.ColorIndex = xlNone
End If
Next rngzelle
'Spalte "Verbaubarkeit bestätigt Schrift weiß färben -> also ausblenden
Range("A1", "IV1").Select
For Each rngzelle In Selection
If rngzelle.Value = "Verbaubarkeit bestätigt" Then
rngzelle.EntireColumn.Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
End If
Next rngzelle
Dim zelle As Range
Dim SelZelle As Range
Dim ZellWert As Long
Dim i As Long
Dim y As Long
i = 0
y = 0
'Hier die Spalte benennen, in der gesucht werden soll, (Standard ist "  _
_
Teilebedarf") !
For Each zelle In ActiveSheet.Range("A1", "IV1").Cells
If zelle.Text = "Teilebedarf" Then
zelle.Activate
Exit For
End If
Next
'Die Zelle wird aktiviert
Set SelZelle = ActiveCell
'Da "SelZelle" nur " Wahr" oder " Falsch" zurückgibt, braucht es hier   _
_
eine Variable ( "Zellwert")
ZellWert = ActiveCell.Column
'MsgBox ("Selektierte Zelle lautet: " & SelZelle)
'Nullen im Bedarf suchen und Zeilen löschen
'Ende -> letzte gefüllte Zeile
lz = Ende
'  ** Durchlauf aller Zeilen
For t = lz To 2 Step -1 'Zählung rückwärts bis Zeile 2
'Program läuft von letzter Zelle her los
If Cells(t, ZellWert).Value = "0" Then
i = i + 1
Else
i = i
End If
If Cells(t, ZellWert).Value = "0" Then
Rows(t).Delete Shift:=xlUp
End If
Next t
'Zellen mit Menge = 0 ausblenden
For Each zelle In ActiveSheet.Range("A1", "IV1").Cells
If zelle.Text = "Menge" Then
zelle.Activate
Exit For
End If
Next
'Die Zelle wird aktiviert
Set SelZelle = ActiveCell
'Da "SelZelle" nur " Wahr" oder " Falsch" zurückgibt, braucht es hier   _
_
eine Variable ( "Zellwert")
ZellWert = ActiveCell.Column
'MsgBox ("Selektierte Zelle lautet: " & SelZelle)
'Nullen im Bedarf suchen und Zeilen löschen
'Ende -> letzte gefüllte Zeile
lz = Ende
'  ** Durchlauf aller Zeilen
For t = lz To 2 Step -1 'Zählung rückwärts bis Zeile 2
'Program läuft von letzter Zelle her los
If Cells(t, ZellWert).Value = "0" Then
y = y + 1
Else
y = y
End If
If Cells(t, ZellWert).Value = "0" Then
Rows(t).Delete Shift:=xlUp
End If
Next t
'Zeilen mit "Dummy für Historie" entfernen
For Each zelle In ActiveSheet.Range("A1", "IV1").Cells
If zelle.Text = "Benennung (Position)" Then
zelle.Activate
Exit For
End If
Next
'Die Zelle wird aktiviert
Set SelZelle = ActiveCell
'Da "SelZelle" nur " Wahr" oder " Falsch" zurückgibt, braucht es hier   _
_
eine Variable ( "Zellwert")
ZellWert = ActiveCell.Column
'MsgBox ("Selektierte Zelle lautet: " & SelZelle)
'Nullen im Bedarf suchen und Zeilen löschen
'Ende -> letzte gefüllte Zeile
lz = Ende
'  ** Durchlauf aller Zeilen
For t = lz To 2 Step -1 'Zählung rückwärts bis Zeile 2
'Program läuft von letzter Zelle her los
If Cells(t, ZellWert).Value = "Dummy für Historie" Then
y = y + 1
Else
y = y
End If
If Cells(t, ZellWert).Value = "Dummy für Historie" Then
Rows(t).Delete Shift:=xlUp
End If
Next t
'If t = 3 Then
'    Call sndPlaySound32("c:\APPLAUSE.wav", 0)
'End If
'Diverse Spalten löschen
Columns("AL:AL").Select
Range("AL:AL,AO:AO,AP:AP,AQ:AQ").Select
Range("AQ1").Activate
ActiveWindow.SmallScroll ToRight:=3
Range("AL:AL,AO:AO,AP:AP,AQ:AQ,AR:AR").Select
Range("AR1").Activate
ActiveWindow.SmallScroll ToRight:=2
Range("AL:AL,AO:AO,AP:AP,AQ:AQ,AR:AR,AV:AV").Select
Range("AV1").Activate
Selection.Delete Shift:=xlToLeft
'Zellen Beschaffungsverantwortung VSC Rot einfärben
'Schleife für AM-Spalte
Dim objCell1 As Range
Set objCell1 = Rows(1).Find(What:="Zust. Am Band", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell1 Is Nothing Then
Rows(1).AutoFilter Field:=objCell1.Column, Criteria1:="="
Set objCell1 = Nothing
Else
MsgBox "Überschrift Zust. Am Band nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell2 As Range
Set objCell2 = Rows(1).Find(What:="Zust. VSC-AV", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell2 Is Nothing Then
Rows(1).AutoFilter Field:=objCell2.Column, Criteria1:="="
Set objCell2 = Nothing
Else
MsgBox "Überschrift Zust. VSC-AV  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell3 As Range
Set objCell3 = Rows(1).Find(What:="Zust. VSL-KEV", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell3 Is Nothing Then
Rows(1).AutoFilter Field:=objCell3.Column, Criteria1:="="
Set objCell3 = Nothing
Else
MsgBox "Überschrift  Zust. VSC-COP  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell4 As Range
Set objCell4 = Rows(1).Find(What:="Zust. VSL", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell4 Is Nothing Then
Rows(1).AutoFilter Field:=objCell4.Column, Criteria1:="="
Set objCell4 = Nothing
Else
MsgBox "Überschrift   Zust. VSL  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell5 As Range
Set objCell5 = Rows(1).Find(What:="Zust. VSC-AM", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell5 Is Nothing Then
Rows(1).AutoFilter Field:=objCell5.Column, Criteria1:=""
Set objCell5 = Nothing
Else
MsgBox "Überschrift   Zust. VSC-AM  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell7 As Range
Set objCell7 = Rows(1).Find(What:="Teilebedarf", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell7 Is Nothing Then
Rows(1).AutoFilter Field:=objCell7.Column, Criteria1:=""
Set objCell7 = Nothing
Else
MsgBox "Überschrift   Teilebedarf  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Alle Filter zurücksetzen
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
'Schleife Auswahl für OU-SPalte
Dim objCell8 As Range
Set objCell8 = Rows(1).Find(What:="Zust. Am Band", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell8 Is Nothing Then
Rows(1).AutoFilter Field:=objCell8.Column, Criteria1:="="
Set objCell8 = Nothing
Else
MsgBox "Überschrift   Zust. Am Band  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell9 As Range
Set objCell9 = Rows(1).Find(What:="Zust. VSC-AV", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell9 Is Nothing Then
Rows(1).AutoFilter Field:=objCell9.Column, Criteria1:="="
Set objCell9 = Nothing
Else
MsgBox "Überschrift   Zust. VSC-AV  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell10 As Range
Set objCell10 = Rows(1).Find(What:="Zust. VSL-KEV", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell10 Is Nothing Then
Rows(1).AutoFilter Field:=objCell10.Column, Criteria1:="="
Set objCell10 = Nothing
Else
MsgBox "Überschrift   Zust. VSC-COP  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell11 As Range
Set objCell11 = Rows(1).Find(What:="Zust. VSL", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell11 Is Nothing Then
Rows(1).AutoFilter Field:=objCell11.Column, Criteria1:="="
Set objCell11 = Nothing
Else
MsgBox "Überschrift   Zust. VSL  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell6 As Range
Set objCell6 = Rows(1).Find(What:="Zust. OU", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell6 Is Nothing Then
Rows(1).AutoFilter Field:=objCell6.Column, Criteria1:=""
Set objCell6 = Nothing
Else
MsgBox "Überschrift   Zust. OU  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
Dim objCell12 As Range
Set objCell12 = Rows(1).Find(What:="Teilebedarf", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell12 Is Nothing Then
Rows(1).AutoFilter Field:=objCell12.Column, Criteria1:=""
Set objCell12 = Nothing
Else
MsgBox "Überschrift   Teilebedarf  nicht gefunden.",  _
vbExclamation, "Hinweis"
End If
'Angezeigten Bereich selektieren & rot färben
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Alle Filter zurücksetzen
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
'Spalte WWBN alle Z-Teile wieder weiß färben
Dim objCell13 As Range
Set objCell13 = Rows(1).Find(What:="WWB-N", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell13 Is Nothing Then
Rows(1).AutoFilter Field:=objCell13.Column, Criteria1:="370Z" _
_
Set objCell13 = Nothing
Else
MsgBox "Überschrift nicht gefunden.", vbExclamation, " _
Hinweis"
End If
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Dim objCell113 As Range
Set objCell113 = Rows(1).Find(What:="WWB-N", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell113 Is Nothing Then
Rows(1).AutoFilter Field:=objCell113.Column, Criteria1:=" _
374Z"
Set objCell113 = Nothing
Else
MsgBox "Überschrift nicht gefunden.", vbExclamation, " _
Hinweis"
End If
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
'Spalte WWBN alle H-Teile wieder weiß färben
Dim objCell14 As Range
Set objCell14 = Rows(1).Find(What:="WWB-N", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell14 Is Nothing Then
Rows(1).AutoFilter Field:=objCell14.Column, Criteria1:="370H" _
_
Set objCell14 = Nothing
Else
MsgBox "Überschrift nicht gefunden.", vbExclamation, " _
Hinweis"
End If
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Dim objCell114 As Range
Set objCell114 = Rows(1).Find(What:="WWB-N", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell114 Is Nothing Then
Rows(1).AutoFilter Field:=objCell114.Column, Criteria1:=" _
374H"
Set objCell114 = Nothing
Else
MsgBox "Überschrift nicht gefunden.", vbExclamation, " _
Hinweis"
End If
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Dim objCell115 As Range
Set objCell115 = Rows(1).Find(What:="WWB-N", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell115 Is Nothing Then
Rows(1).AutoFilter Field:=objCell115.Column, Criteria1:=" _
224H"
Set objCell115 = Nothing
Else
MsgBox "Überschrift nicht gefunden.", vbExclamation, " _
Hinweis"
End If
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
'Erste Reihe weiß färben
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Dim objCell116 As Range
Set objCell116 = Rows(1).Find(What:="WWB-N", _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell116 Is Nothing Then
Rows(1).AutoFilter Field:=objCell116.Column, Criteria1:=" _
220H"
Set objCell116 = Nothing
Else
MsgBox "Überschrift nicht gefunden.", vbExclamation, " _
Hinweis"
End If
ActiveSheet.UsedRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
'Erste Reihe weiß färben
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 45
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Farbe setzen
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Range("A1", "IV1").Select
For Each rngzelle In Selection
If rngzelle.Value = "Verbaubarkeit bestätigt" Then
rngzelle.EntireColumn.Select
Selection.ClearContents
End If
Next rngzelle
'Rahmen setzen
ActiveSheet.UsedRange.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'Spalten am linken Rand ausblenden
Columns("AU:AU").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.EntireColumn.Hidden = True
' Erste Zeile breitere Rahmenlinien setzen
Rows("1:1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Range("A2").Select
'Sound abspielen nur für WAV Dateien
'                                 Application.ExecuteExcel4Macro _
'                                "SOUND.PLAY(,""C:\Users\Schusfra\Desktop\applause4.wav"")"
'Errorhandler:
' Debug.Print Err.Description, Err.Number, Err.Source
MsgBox ("Datei fertig umgeschrieben.  " & "Es wurden " & i & "  Zeilen mit Teilebedarf = 0 " &  _
_
" und  " & y & " Zeilen mit Menge = 0 gelöscht ! "), vbExclamation, "Computer sagt:"
End Sub