Hello,
I am working on some code to break out logic parts from a netlist to individual columns. It is a work in progress, but as I try to run it to check on changes I make... I notice it is painfully slow. Any tips on tweaks to speed it up would be greatly appreciated.
ScreenUpdating doesn't help -- I will probably remove it -- because the worksheet being manipulated is not shown.
I would also like to have it report out how many individual items it moves to a particular column... it reports rows now, but it is not accurate and needs to be fixed. An item count would be preferable.
Thanks in advance for your help.
I am working on some code to break out logic parts from a netlist to individual columns. It is a work in progress, but as I try to run it to check on changes I make... I notice it is painfully slow. Any tips on tweaks to speed it up would be greatly appreciated.
ScreenUpdating doesn't help -- I will probably remove it -- because the worksheet being manipulated is not shown.
I would also like to have it report out how many individual items it moves to a particular column... it reports rows now, but it is not accurate and needs to be fixed. An item count would be preferable.
Code:
Sub PADSLayoutReportFormatter()
Application.ScreenUpdating = False
Dim FoundCellCol1 As Range
Dim TopCell1 As Range
Dim WorkRange As Range
Dim lastLine As Long
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim SourceCell As Range
Dim wsheet As Worksheet
Dim SourceSheet As Worksheet
Set SelectedSheet = ActiveSheet
Set SourceSheet = ActiveSheet
On Error Resume Next
Set wsheet = Sheets("PADS NET Report")
' Worksheet doesn't exist
If wsheet Is Nothing Then
lastLine = ActiveSheet.UsedRange.Cells.Count
SourceSheet.Activate
Sheets.Add.Name = "PADS NET Report"
Sheets("PADS NET Report").Tab.ColorIndex = 37
Sheets("PADS NET Report").Move After:=SelectedSheet
SourceSheet.Activate
Else
' Worksheet does exist
If wsheet Is Sheets("PADS NET Report") Then
'Text for Yes/No MessageBox to Copy to Worksheet
MyNote = "A Worksheet named: 'PADS NET Report' has been found." & vbNewLine & "OK to deleta existing data and copy to it?"
'Display Yes/No MessageBox
Answer = MsgBox(MyNote, vbQuestion + vbYesNo, "'PADS NET Report' Worksheet Query")
If Answer = vbNo Then
'Code for No button Press
MsgBox "No data will be deleted or copied."
End
Else
'Code for Yes button Press
Worksheets("PADS NET Report").Activate
Cells.Select
Selection.Delete Shift:=xlUp
SelectedSheet.Activate
SourceSheet.Activate
lastLine = ActiveSheet.UsedRange.Cells.Count
End If
End If
End If
' Select Active Range
Set WorkRange = ActiveSheet.UsedRange
' Loop through each cell, find "Component Type" Column
For Each cell In WorkRange
If cell.Value = "Component Type" Then
If FoundCellCol1 Is Nothing Then
Set FoundCellCol1 = cell
Else
Set FoundCellCol1 = Application.Union(FoundCellCol1, cell)
End If
End If
Next cell
' Show message, or select the cells
If FoundCellCol1 Is Nothing Then
MsgBox "No cells contain: Component Type."
Else
FoundCellCol1.Select
End If
Set TopCell1 = Cells(ActiveCell.Row, ActiveCell.Column)
' Set "Component Type" cell as top cell in "Component Type" Column
For i = 1 To lastLine
For Each cell In TopCell1.Offset(i - 1, 0)
If InStr(cell.Text, "DUT") <> 0 Then
toCopy = True
End If
' Copy "DUT" Cells to "PADS NET Report" Worksheet
Next
If toCopy = True Then
Columns("A:A").Select
Columns("A:A").Copy Destination:=Sheets("PADS NET Report").Columns("A:A")
Rows("1:1").Select
Rows("1:1").Copy Destination:=Sheets("PADS NET Report").Rows("1:1")
Cells(i, 2).Copy Destination:=Sheets("PADS NET Report").Cells(i, 2)
End If
toCopy = False
Next
i = MsgBox(((i) & " 'DUT' Cells(s) were copied!"), vbOKOnly, "Result")
' Select Active Range
Set WorkRange = ActiveSheet.UsedRange
' Loop through each cell, find "Component Type" Column
For Each cell In WorkRange
If cell.Value = "Component Type" Then
If FoundCellCol1 Is Nothing Then
Set FoundCellCol1 = cell
Else
Set FoundCellCol1 = Application.Union(FoundCellCol1, cell)
End If
End If
Next cell
' Show message, or select the cells
If FoundCellCol1 Is Nothing Then
MsgBox "No cells contain: Component Type."
Else
FoundCellCol1.Select
End If
Set TopCell1 = Cells(ActiveCell.Row, ActiveCell.Column)
' Set "Component Type" cell as top cell in "Component Type" Column
For i = 1 To lastLine
For Each cell In TopCell1.Offset(i - 1, 0)
If InStr(cell.Text, "CAP") <> 0 Then
toCopy = True
End If
' Copy "CAP" Cells to "PADS NET Report" Worksheet
Next
If toCopy = True Then
Columns("A:A").Select
Columns("A:A").Copy Destination:=Sheets("PADS NET Report").Columns("A:A")
Rows("1:1").Select
Rows("1:1").Copy Destination:=Sheets("PADS NET Report").Rows("1:1")
Cells(i, 2).Copy Destination:=Sheets("PADS NET Report").Cells(i, 4)
End If
toCopy = False
Next
i = MsgBox(((i) & " 'CAP' Cells(s) were copied!"), vbOKOnly, "Result")
' Select Active Range
Set WorkRange = ActiveSheet.UsedRange
' Loop through each cell, find "Component Type" Column
For Each cell In WorkRange
If cell.Value = "Component Type" Then
If FoundCellCol1 Is Nothing Then
Set FoundCellCol1 = cell
Else
Set FoundCellCol1 = Application.Union(FoundCellCol1, cell)
End If
End If
Next cell
' Show message, or select the cells
If FoundCellCol1 Is Nothing Then
MsgBox "No cells contain: Component Type."
Else
FoundCellCol1.Select
End If
Set TopCell1 = Cells(ActiveCell.Row, ActiveCell.Column)
' Set "Component Type" cell as top cell in "Component Type" Column
For i = 1 To lastLine
For Each cell In TopCell1.Offset(i - 1, 0)
If InStr(cell.Text, "RES") <> 0 Then
toCopy = True
End If
' Copy "RES" Cells to "PADS NET Report" Worksheet
Next
If toCopy = True Then
Columns("A:A").Select
Columns("A:A").Copy Destination:=Sheets("PADS NET Report").Columns("A:A")
Rows("1:1").Select
Rows("1:1").Copy Destination:=Sheets("PADS NET Report").Rows("1:1")
Cells(i, 2).Copy Destination:=Sheets("PADS NET Report").Cells(i, 5)
End If
toCopy = False
Next
i = MsgBox(((i) & " 'RES' Cells(s) were copied!"), vbOKOnly, "Result")
Application.ScreenUpdating = True
Worksheets("PADS NET Report").Activate
ActiveSheet.UsedRange.Columns.AutoFit
End Sub