Prompt Detail:
Sub FilterData()
Dim ws As Worksheet
Dim newWs As Worksheet
Dim lastRow As Long
Dim filterRange As Range
Dim filterCriteria As Variant
Dim i As Long
'Disable events to prevent the Worksheet_Change event from being triggered
Application.EnableEvents = False
'Set the worksheet to filter
Set ws = ThisWorkbook.Worksheets("ORP_Daten")
'Check if the "BE daten gefiltert" sheet already exists, delete it if it does
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("BE-Daten gefiltert").Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Create a new worksheet to copy the filtered data
Set newWs = ThisWorkbook.Worksheets.Add(After:=ws)
newWs.Name = "BE-Daten gefiltert"
'Set the range to filter
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Assuming column A has data till the last row
Set filterRange = ws.Range("A1:O" & lastRow) 'Assuming data is in columns A to O
'Set the filter criteria
filterCriteria = Array("CBE", "CMO", "CSE") 'Filter1: Values in column C = CBE or CMO or CSE
filterRange.AutoFilter Field:=3, Criteria1:=filterCriteria, Operator:=xlFilterValues
filterCriteria = Array("CFAK1", "CFMO1", "CFSE1") 'Filter2: Values in column D = CFAK1 or CFMO1 or CFSE1
filterRange.AutoFilter Field:=4, Criteria1:=filterCriteria, Operator:=xlFilterValues
filterRange.AutoFilter Field:=5, Criteria1:="<>", Operator:=xlAnd 'Filter3: Values in column E should not be empty
filterRange.AutoFilter Field:=8, Criteria1:=">0", Operator:=xlAnd 'Filter4: Values in column H should be greater than zero
filterRange.AutoFilter Field:=13, Criteria1:=">0", Operator:=xlAnd 'Filter5: Values in column M should be greater than zero
'Copy the filtered data to the new worksheet
filterRange.SpecialCells(xlCellTypeVisible).Copy newWs.Range("A1")
'Clear the filter
filterRange.AutoFilter
'Set the column width to the maximum string length of data in each column
Dim col As Range
For Each col In newWs.UsedRange.Columns
col.AutoFit
col.ColumnWidth = col.ColumnWidth + 2 'Add some extra space for readability
Next col
'Set the row height for the first row
newWs.Rows(1).RowHeight = 45
'Set the row height for columns 6, 9, 10, 11
newWs.Columns(6).ColumnWidth = 51
newWs.Columns(9).ColumnWidth = 13
newWs.Columns(10).ColumnWidth = 14
newWs.Columns(11).ColumnWidth = 15.3
'Autofit the row height for all rows
newWs.Cells.EntireRow.AutoFit
'Add columns P - S and perform calculations
With newWs
.Columns("P:S").Insert Shift:=xlToRight
.Range("P1").Value = "HK"
.Range("P1").Font.Bold = True
.Range("P1").ColumnWidth = 8
.Range("Q1").Value = "Ausfallkosten Gesamt"
.Range("Q1").Font.Bold = True
.Range("Q1").ColumnWidth = 12.3
.Range("Q1").Interior.Color = RGB(189, 215, 238)
.Range("R1").Value = "Ausfallkosten lt. Vorgabe / kalkuliert"
.Range("R1").Font.Bold = True
.Range("R1").ColumnWidth = 12.6
.Range("R1").Interior.Color = RGB(248, 203, 173)
.Range("S1").Value = "zusätzliche/ eingesparte Ausfallkosten"
.Range("S1").Font.Bold = True
.Range("S1").ColumnWidth = 12.9
.Range("S1").Interior.Color = RGB(198, 224, 180)
Dim lastRowNewWs As Long
lastRowNewWs = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("P2:P" & lastRowNewWs).Formula = "=IF(A2<>"""", L2/(G2+H2), """")"
.Range("Q2:Q" & lastRowNewWs).Formula = "=IF(A2<>"""", G2*P2, """")"
.Range("R2:R" & lastRowNewWs).Formula = "=IF(A2<>"""", P2*((100-O2)*(G2+H2)/100), """")"
.Range("S2:S" & lastRowNewWs).Formula = "=IF(A2<>"""", R2-Q2, """")"
'Number formatting
.Range("P2:P" & lastRowNewWs).NumberFormat = "0.00"
.Range("Q2:S" & lastRowNewWs).NumberFormat = "#,##0 €"
'Alignment
.Range("A:E,G:O,P:S").VerticalAlignment = xlCenter
.Range("A:E,G:O,P:S").HorizontalAlignment = xlCenter
.Range("F:F").HorizontalAlignment = xlLeftAcrossSelection
.Columns("P:S").HorizontalAlignment = xlCenter
End With
'Enable events again
Application.EnableEvents = True
'Select the new worksheet
newWs.Activate
End Sub
in the above program i am getting a error 400 message but the program is functioning good. rewrite me the above VBA code to avoid this error from occurring
-
Muchas gracias. ?Como puedo iniciar sesion? - nsztenqcem - 1 month ago
Add a comment