VBA hilfe
21.12.2017 05:42:35
Tim
dieser Code ist hinter einen Button hinterlegt:
Sub Buero()
On Error GoTo Fehler
Dim WB1, WB2
Application.ScreenUpdating = False
Set WB1 = Workbooks("Nachschub Rollregal Analyse.xlsm")
Workbooks.OpenText Filename:= _
"G:\Transfer\Allgemein\Datei Txt\Platzkapazität GD16 Rollregal.txt", Origin:= _
xlWindows, StartRow:=6, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=True, OtherChar:=";", FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
True
Set WB2 = ActiveWorkbook
WB2.ActiveSheet.Columns("A:C").Copy
WB1.Sheets("Tabelle1").Columns("A:A").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.DisplayAlerts = False ' Hinweis Zwischenablage unterdrücken
WB2.Close False
Application.DisplayAlerts = True
Workbooks.OpenText Filename:= _
"G:\Transfer\Allgemein\Datei Txt\Platzkapazität GD16 Reserve.txt", Origin:= _
xlWindows, StartRow:=6, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=True, OtherChar:=";", FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
True
Set WB2 = ActiveWorkbook
WB2.ActiveSheet.Columns("A:C").Copy
WB1.Sheets("Tabelle2").Columns("A:A").PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False
WB2.Close False
Application.DisplayAlerts = True
WB1.Sheets("Tabelle2").Name = "Reserve"
WB1.Sheets("Tabelle1").Name = "Rollregal"
WB1.Sheets("Tabelle3").Name = "Artikelstatus"
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
Err.Clear
Sheets("Artikelstatus").Select
Range("A1").Select
Application.DisplayAlerts = True
ChDir "G:\Transfer\Allgemein\WE\Artikelstatus"
Workbooks.Open Filename:="G:\Transfer\Allgemein\WE\Artikelstatus\Aktuell.xlsb"
Columns("A:N").Copy
Workbooks("Nachschub Rollregal Analyse.xlsm").Sheets("Artikelstatus").Range("A1").PasteSpecial _
Paste:=xlPasteValues
Application.CutCopyMode = False
Workbooks("Aktuell.xlsb").Close
Application.DisplayAlerts = True
Sheets("Reserve").Select
Range("D2") = "=R[1]C[-3]"
Range("E2") = "=R[1]C[-2]"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D50000")
Range("D2:D50000").Select
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E50000")
Range("E2:E50000").Select
Columns("D:E").Select
Range("E1").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:E").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Reserve").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Reserve").Sort.SortFields.Add Key:=Range( _
"A2:A50000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Reserve").Sort
.SetRange Range("A2:E50000")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("J16").Select
With ActiveSheet.UsedRange
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=if(iserror(find(""-"",RC1)),0,if(iserror(find(""."",RC1)),Row(),0))"
.Cells(1, 1).Value = 0
.EntireRow.RemoveDuplicates .Column, xlNo
.ClearContents
End With
End With
Range("A2:G2").ClearContents
Range("A2") = "Reserveplatz"
Range("B2") = "Palettentyp"
Range("C2") = "Reserve B"
Range("D2") = "Artikelnummer"
Range("E2") = "Menge"
Range("G9").Select
With Sheets("Rollregal")
With .Range("D2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row)
.Columns(1).FormulaR1C1 = "=R[1]C[-3]"
.Columns(2).FormulaR1C1 = "=if(RC[-1]=R[-1]C[-1],R[-1]C,SUMIF(C[-4]:C[-2],RC[-1],C[-2])) _
.Formula = .Value
End With
End With
Sheets("Rollregal").Select
Columns("A:E").Select
ActiveWorkbook.Worksheets("Rollregal").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Rollregal").Sort.SortFields.Add Key:=Range( _
"A2:A35000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Rollregal").Sort
.SetRange Range("A2:E35000")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("F2").Select
With ActiveSheet.UsedRange
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "=if(iserror(find(""-"",RC1)),0,if(iserror(find(""."",RC1)),Row(),0))"
.Cells(1, 1).Value = 0
.EntireRow.RemoveDuplicates .Column, xlNo
.ClearContents
End With
End With
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Range("B3").Select
Columns("A:A").ColumnWidth = 12.71
Columns("B:B").Select
Selection.ClearContents
Range("A1") = "Kommplatz"
Range("B4").Select
Columns("A:A").EntireColumn.AutoFit
Range("B1") = "Bereich"
Range("C1") = "Einlagers."
Columns("C:C").ColumnWidth = 13.57
Columns("C:C").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Range("C1").Select
Range("D1") = "Artikelnummer"
Range("D4").Select
Columns("D:D").ColumnWidth = 14.14
Range("E1") = "Menge Kommplatz"
Range("E1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Range("F1").Select
Range("F1") = "Menge Reserve"
Range("F2").Select
Columns("F:F").ColumnWidth = 7.29
Range("G1") = "Lagerplatzkapazität"
Range("G2").Select
Rows("1:1").RowHeight = 33.75
Range("H1") = "% Belegt"
Range("H2").Select
Columns("H:H").ColumnWidth = 9
Range("I1") = "%Frei"
Range("I2").Select
Columns("I:I").ColumnWidth = 9
Columns("H:I").Select
Range("I1").Activate
Selection.NumberFormat = "0%"
Columns("E:G").Select
Range("G1").Activate
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = False
Selection.Font.Bold = True
Columns("H:I").Select
Range("I1").Activate
Selection.Font.Bold = False
Selection.Font.Bold = True
Columns("A:I").Select
Range("I1").Activate
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
'Range("A1:I1").Select
'Selection.AutoFilter
'Range("J1").Select
Range("F1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("G1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("G:G").ColumnWidth = 9.86
Range("F1:G1").Select
Columns("F:F").ColumnWidth = 9.57
Columns("F:F").ColumnWidth = 13
Columns("G:G").ColumnWidth = 9.57
Columns("H:H").ColumnWidth = 10.14
Columns("I:I").ColumnWidth = 10.14
Range("F2") = "=SUMIF(Reserve!C[-2]:C[-1],Rollregal!RC[-2],Reserve!C[-1])"
Range("G2") = "=IFERROR(VLOOKUP(RC[-3],Artikelstatus!C[-6]:C[-1],6,FALSE),""k.Pkz"")"
Range("H2") = "=RC[-3]/RC[-1]"
Columns("H:I").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("I2") = "=IF(RC[-3]=0,""k.Reserve"",SUM(1-RC[-1]))"
Range("F2:I2").AutoFill Destination:=Range("F2:I" & Cells(Rows.Count, "A").End(xlUp).Row), Type: _
=xlFillDefault
Range("B2") = "=MID(RC[1],8,2)"
Range("B2:B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, "A").End(xlUp). _
Row), Type:=xlFillDefault
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
Selection.ColumnWidth = 11 'weiter
Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B2").Select
Columns("B:B").Select
Application.CutCopyMode = False
Columns("A:E").Select
ActiveWorkbook.Worksheets("Rollregal").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Rollregal").Sort.SortFields.Add Key:=Range( _
"C2:C30000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Rollregal").Sort
.SetRange Range("A1:E30000")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1:I1").Select
Range("I1").Activate
Selection.AutoFilter
ActiveSheet.Range("$A$1:$I$30000").AutoFilter Field:=9, Criteria1:=RGB(255, _
0, 0), Operator:=xlFilterCellColor
Range("A1").Select
Dim Ende As Integer
ActiveSheet.PageSetup.PrintArea = ""
Ende = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.PageSetup.PrintArea = "$A$1:$I$" & Ende
' neuer Test
Columns("J:J").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 14.71
Columns("L:L").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("L1") = "=SUMPRODUCT(SUBTOTAL(103,INDIRECT(""B""&ROW(R:R[8498])))*(R1C2:R8499C2=""20"" _
))"
Selection.NumberFormat = """B.20:"" 0 "
Range("L4").Select
ActiveSheet.Buttons.Add(595.5, 1.5, 71.25, 28.5).Select
Selection.OnAction = "Drucken.mein_Drucken"
Selection.Characters.Text = "Drucken"
With Selection.Characters(Start:=1, Length:=7).Font
.Name = "Calibri"
.FontStyle = "Standard"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
Range("J45").Select
ThisWorkbook.SaveCopyAs "G:\Transfer\Allgemein\TPL\Rollregal\2017\" & _
Environ("username") & "_" & Format(Now, "yyyy_mm_dd_hhmm") & _
".xlsm"
End Sub
wenn aber ein Kollege versehendlich die Datei Speichert, funktioniert danach das Programm nicht mehr.
Kann mir jemand weiterhelfen, das Speichern verboten ist.
Ich wollte es per Vorlage machen, aber da funktioniert der Code nimmer.
Hoffe ihr könnt mir helfen.
Danke