Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1596to1600
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA hilfe

VBA hilfe
21.12.2017 05:42:35
Tim
Hallo zusammen,
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

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA hilfe
21.12.2017 05:54:41
Hajo_Zi
es soll also überhaupt nicht mehr gespeichert werden. DieseArbeitsmappe
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True
End Sub


Ich gebe keinen Dank für eine Rückmeldung, da ich durch solche Beiträge nicht meine Beitragszahl erhöhen muss.
Also ich schreibe keine Beiträge mit dem Betreff "Gerne u. Danke für die Rückmeldung. o.w.T."
Rückmeldung ist ja in der Heutigen Zeit nicht üblich und die wenigen die eine Rückmeldung geben,
mögen mir das verzeihen, das kein Danke für eine Rückmeldung kommt.
Beiträge von Werner, Luc, robert und folgende lese ich nicht.
Anzeige
AW: VBA hilfe
21.12.2017 09:40:51
Tim
Hallo,
ich kann diesen Code nicht in meiner Arbeitsmappe Speichern. Weil es es nicht zu lässt.
Wie bekomme ich dann den Code rein ?
Danke
AW: VBA hilfe
21.12.2017 09:50:05
Nepumuk
Hallo Tim,
aktiviere den Entwurfsmodus dann kannst du speichern da dann keine Makros ausgeführt werden.
Gruß
Nepumuk
DANKESCHÖÖÖN
21.12.2017 10:41:49
Tim
....

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige