as avea nevoie de ajutorul vostru in corectarea unui cod VBA in vederea optimizarii performantelor(uneori ruleaza foarte mult) si in coreactarea unei bucati de cod ce ar trebui sa stearga toate randurile daca in coloana 7 si 11 au valori = 0(coloanele 7 si 11 sunt cele ramase dupa rularea bucatii de cod pana la partea in care se cere in Input Box adaugarea unei valori de catre user)
atasez un fiseir ca exemplu si codul care imi da batai de cap
+ partea de cod comentata in care am incercat sa sterg liniile cu val 0Multumesc frumos
CP
Cod: Selectaţi tot
Sub TransformExcelFile()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim FilePath As String
Dim WB As Workbook
Dim ws As Worksheet
Dim lrow As Long
Dim i As Long
Dim colRange As Range
Dim lastCol As Long
Dim filterRange As Range
Dim cell As Range
Dim lastERow As Long
Dim userValue As String
Dim progressiveNumber As Integer
Dim currentNumber As Long
Dim col1 As Long ' Column number of the first column to check
Dim col2 As Long ' Column number of the second column to check
' Prompt the user to open a file and get the file path
FilePath = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx")
' Check if a file was selected
If FilePath = "False" Then
MsgBox "No file selected. Exiting..."
Exit Sub
End If
' Open the selected workbook
Set WB = Workbooks.Open(FilePath)
' Set the active worksheet
Set ws = WB.ActiveSheet
' Delete the first row
ws.Rows(1).Delete
' Remove the second column
ws.Columns(2).Delete
' Rename cell A1 to "ID"
ws.Cells(1, 1).Value = "ID"
' Rename cell B2 to "Finished product"
ws.Cells(1, 2).Value = "Finished product"
' Trim and clean the values in the first row
For i = 1 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
ws.Cells(1, i).Value = Trim(WorksheetFunction.Clean(ws.Cells(1, i).Value))
Next i
' Delete all empty rows in the worksheet
lrow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
For i = lrow To 1 Step -1
If WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
ws.Rows(i).Delete
End If
Next i
' Find the last column containing "Material" in the first row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For i = 3 To lastCol
If ws.Cells(1, i).Value = "Material" Then
Exit For
End If
Next i
' Delete columns from C to the "Material" column
If i <= lastCol Then
ws.Columns("C:" & Split(Cells(1, i - 1).Address, "$")(1)).Delete
End If
' Loop through column B and copy values from column C where B is not blank
For Each cell In ws.Range("B1:B" & lrow)
If Not IsEmpty(cell.Value) Then
cell.Value = ws.Cells(cell.Row, "C").Value
End If
Next cell
' Find the last row with a value in column E
lastERow = ws.Cells(Rows.Count, "E").End(xlUp).Row
' Fill down values in column B
For i = 3 To lastERow
If IsEmpty(ws.Cells(i, 2)) Then
ws.Cells(i, 2).Value = ws.Cells(i - 1, 2).Value
End If
Next i
' Remove formulas in column B
ws.Range("B:B").Value = ws.Range("B:B").Value
' Fill down values in column L
For i = 3 To lastERow
If IsEmpty(ws.Cells(i, 12)) Then
ws.Cells(i, 12).Value = ws.Cells(i - 1, 12).Value
End If
Next i
' Fill down values in column M
For i = 3 To lastERow
If IsEmpty(ws.Cells(i, 13)) Then
ws.Cells(i, 13).Value = ws.Cells(i - 1, 13).Value
End If
Next i
' Remove formulas in column B
ws.Range("B:B").Value = ws.Range("B:B").Value
'Find the last row in column C
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
' Loop through each row in column C
For i = 1 To lastRow
' Check if the cell in column C is blank
If IsEmpty(ws.Cells(i, "C").Value) Then
' Copy the value from column P to column C
ws.Cells(i, "C").Value = ws.Cells(i, "P").Value
End If
' Check if the cell in column C is blank
If Trim(ws.Cells(i, "D").Value) = "" Then
' Copy the text from column O (from the right till the first space) to column D
Dim cellO As String
cellO = Trim(ws.Cells(i, "O").Value)
ws.Cells(i, "D").Value = Right(cellO, Len(cellO) - InStrRev(cellO, " "))
End If
Next i
' Filter and delete rows in column R
ws.Range("Q:Q").AutoFilter Field:=1, Criteria1:="="
ws.Range("Q:Q").AutoFilter Field:=1, Criteria1:="Semi finished goods usage"
' Delete visible rows (i.e., rows that meet the filter criteria)
On Error Resume Next
ws.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
' Turn off the filter
ws.AutoFilterMode = False
' Filter and delete blank rows in column R
ws.Range("Q:Q").AutoFilter Field:=1, Criteria1:="="
ws.Range("Q:Q").AutoFilter Field:=1, Criteria1:=""
' Delete visible rows (i.e., rows that meet the filter criteria)
On Error Resume Next
ws.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
' Turn off the filter
ws.AutoFilterMode = False
' Dim col1 As Long ' Column number of the first column to check
' Dim col2 As Long ' Column number of the second column to check
' Set the worksheet, columns to check, and last row
' Set ws = ThisWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with your sheet name
' col1 = 1 ' Replace with the column number you want to check
' col2 = 2 ' Replace with the column number you want to check
' lastRow = ws.Cells(ws.Rows.Count, col1).End(xlUp).Row
' Loop through the rows from the bottom to the top
' For i = lastRow To 2 Step -1 ' Start from the last row and go up to the 2nd row
' If ws.Cells(i, col1).Value = 0 And ws.Cells(i, col2).Value = 0 Then
' If both columns have zero values, delete the row
' ws.Rows(i).Delete
' End If
' Next i
' Get the user input for the value (mandatory)
userValue = InputBox("Please enter a value to be concatenated with the ID:")
' Set the initial value for the progressive number
currentNumber = 1
' Check if the user provided a value
If userValue = "" Then
MsgBox "You must provide a value. Exiting..."
Exit Sub
End If
For i = 2 To lastERow
If Not IsEmpty(ws.Cells(i, 5).Value) Then
' Check if the user entered a value, and if not, use the progressive number
If userValue <> "" Then
ws.Cells(i, 1).Value = currentNumber & "_" & userValue
End If
currentNumber = currentNumber + 1
End If
Next i
ws.UsedRange.Columns.AutoFit
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
