Prompt Title: VBA program to filter data from original data bank and copy into a new sheet

Created 5 months ago
Votes 0
Views 81 times

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
Adarsh Sharma
Shared 1 prompt
Created 5 months ago

Leave a Comment

Related Tag Prompts

Act as a PHP Interpreter
10 months ago 2023-01-22 22:32:40 ilhanaydinli
Excel Expert
10 months ago 2023-01-22 21:26:36 AIPRM