AW: VBA Warten
11.02.2021 11:40:12
UweD
Hallo
erstmal...
Auf select kann in 99% verzichtet werden.
Ich hab den Anfang mal umgebaut. kannst du analog fortführen
zum eigenlichen Proble...
meinst du das so.
Option Explicit
Public enmResult As VbMsgBoxResult
Sub Gundsatz()
Dim lngLast As Long
Application.ScreenUpdating = False
With Sheets("Tabelle1")
.Columns("E:F").NumberFormat = "hh:mm;@"
.Columns("G:G").NumberFormat = "#,##0.00"
.Columns("I:I").Cut
.Columns("A:A").Insert Shift:=xlToRight
'Füge neben die Splate A eine neue Spalte ein
.Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Gebe der Spalte eine Überschrift
.Range("B1") = "LANR"
'Formatiere die Zelle als Text mit 7 mal 0 von links
lngLast = Cells(Rows.Count, 1).End(xlUp).Row
.Range("B2").Resize(lngLast - 1, 1).FormulaR1C1 = "=TEXT(RC[-1],""0000000"")"
'Kopieren und einfügen, damit nur die Werte aber nicht die Formlen stehen bleiben
.Columns("B:B").Value = .Columns("B:B").Value
.Columns("A:A").Delete Shift:=xlToLeft
.Columns("A:A").Cut
.Columns("J:J").Insert Shift:=xlToRight
.Columns("H:H").Cut
.Columns("A:A").Insert Shift:=xlToRight
'Füge neben die Splate A eine neue Spalte ein
.Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Gebe der Spalte eine Überschrift
.Range("B1") = "LANR"
'... usw
' Range("B2").Select
' 'Formatiere die Zelle als Text mit 7 mal 0 von links
' ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""000000000"")"
' lngLast = Cells(Rows.Count, 1).End(xlUp).Row
' 'Kopiere die Formel bis zur letzen befüllten Zelle
' Range("B2").AutoFill Destination:=Range("B2:B" & lngLast)
' 'Kopieren und einfügen, damit nur die Werte aber nicht die Formlen _
stehen bleiben
' Columns("B:B").Select
' Selection.Copy
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
' :=False, Transpose:=False
' Application.CutCopyMode = False
' Columns("A:A").Select
' Selection.Delete Shift:=xlToLeft
' Range("A1").Select
' ActiveWorkbook.Save
' ActiveCell.FormulaR1C1 = "BSNR"
' Columns("A:A").Select
' Selection.Cut
' Columns("I:I").Select
' Selection.Insert Shift:=xlToRight
' Columns("C:D").Select
' Selection.NumberFormat = "m/d/yyyy"
' Range("A1").Select
' Columns("H:I").Select
' Selection.Replace What:="NULL", Replacement:="", LookAt:=xlPart, _
' SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
' ReplaceFormat:=False
' Range("P1").Select
' ActiveCell.FormulaR1C1 = "Code"
' Range("P2").Select
' ActiveCell.FormulaR1C1 = "=RC[-7]&RC[-8]"
' Columns("P:P").EntireColumn.AutoFit
' Range("P2").AutoFill Destination:=Range("P2:P" & lngLast)
' Columns("P:P").Select
' Selection.Copy
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks _
' :=False, Transpose:=False
' Application.CutCopyMode = False
' Cells.Select
' ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
' ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add Key:=Range( _
_
' "H2:H65000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
_
' xlSortTextAsNumbers
' With ActiveWorkbook.Worksheets("Tabelle1").Sort
' .SetRange Range("A1:P65000")
' .Header = xlYes
' .MatchCase = False
' .Orientation = xlTopToBottom
' .SortMethod = xlPinYin
' .Apply
' End With
End With
MsgBox "Bitte nun A und E kopieren und in die ARA einfügen, danach die Reiter A und E hier _
her kopieren", vbInformation, "Grundsatz"
Call Application.OnTime(Now + TimeSerial(0, 1, 0), "Weiter")
End Sub
Private Sub Weiter()
enmResult = MsgBox("!! ACHTUNG !!, Haben Sie die Reiter kopiert? dann Ja sonst Nein " & _
"klicken und die Reiter erst kopieren, danke", vbYesNo Or vbQuestion, "Grundsatz")
If enmResult = vbYes Then
With Sheets("Tabelle1")
.Range("Q1") = "HA/FA"
.Range("R1").Select
End With
End If
End Sub
LG UweD