Good morning,
I am new to the forum, I joined seeking some experienced assistance. I am hoping that someone would be willing to help me clean up the code below. Obviously I do not have experience with writing macros but through trial and error the code is working basically. I really need to to perform faster, it is a slow to execute code and I was hoping that a more experienced person could identify and clean up some of the issues that I suspect are in the way I wrote this macro.
Thank you for looking.
Code
Sub ACCUBID_EXTENSION_CONSOLIDATION()
'
'
'
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = False
Application.Calculation = xlManual
'
'
'
Sheets("ACCUBID EXTENSION").Visible = True
Sheets("Accubid Extension").Select
ActiveSheet.Unprotect "PRECON"
Range("B2:G10000").Select
Range("G10000").Activate
Selection.ClearContents
Range("X2:AD10000").Select
Range("AD10000").Activate
Selection.ClearContents
Range("AK1:AN10000").Select
Range("AN10000").Activate
Selection.ClearContents
Range("AT2:AQ10000").Select
Range("AQ10000").Activate
Selection.ClearContents
Range("K2:l10000").Select
Range("l10000").Activate
Selection.ClearContents
Range("AV2:AV10000").Select
Range("AV10000").Activate
Selection.ClearContents
Range("AX2:AX10000").Select
Range("AX10000").Activate
Selection.ClearContents
Range("AZ2:AZ10000").Select
Range("AZ10000").Activate
Selection.ClearContents
Range("BB2:BB10000").Select
Range("BB10000").Activate
Selection.ClearContents
'
'
' EXTENSION_SORT_BID_ITEM_GROUPED_1
Sheets("EXTENSION").Visible = True
Sheets("EXTENSION").Select
Dim t As Range
Dim s As Range
Dim v As Range
' Find "Name" in Row 1
With Sheets("EXTENSION").Rows(1)
Set t = .Find(InputBox("Enter 1st bid breakdown type: Bid Item, Drawing, Area, Phase, or System"))
If Not t Is Nothing Then
Columns(t.Column).EntireColumn.Copy _
Destination:=Sheets("ACCUBID EXTENSION").Range("AA1")
Else: MsgBox "Title Not Found"
End If
End With
' Find "Name" in Row 2
With Sheets("EXTENSION").Rows(1)
Set s = .Find(InputBox("Enter 2nd bid breakdown type, or hit OK"))
If Not s Is Nothing Then
Columns(s.Column).EntireColumn.Copy _
Destination:=Sheets("ACCUBID EXTENSION").Range("AB1")
Else: MsgBox "Title Not Found"
End If
End With
' Find "Name" in Row 3
With Sheets("EXTENSION").Rows(1)
Set v = .Find(InputBox("Enter 3rd bid breakdown type, or hit OK"))
If Not v Is Nothing Then
Columns(v.Column).EntireColumn.Copy _
Destination:=Sheets("ACCUBID EXTENSION").Range("AC1")
Else: MsgBox "Title Not Found"
End If
End With
'
'
' ITEM DESCRIPTION
Sheets("EXTENSION").Select
Dim strColName1 As String
Dim intRng1 As Integer
Dim i As Integer
Dim strVal1 As String
intRng1 = 20 'To get the No. of Columns Available to Search
strColName1 = "Item Description" 'To Get the Column Name to Search
strSheetName = "Accubid Extension" 'To get the Sheet Name to paste the content
For i = 1 To intRng1
' Store the Cell Value
strVal1 = Cells(1, i)
'Check the Value with the User given column name
If UCase(strVal1) = UCase(strColName1) Then
' Select and Copy
Cells(1, i).Select
Range(Selection, Selection.End(xlDown).Offset(9997, 0)).Select
Selection.Copy
'
'
'Select and Paste
Sheets(strSheetName).Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
'
'
' QUANTITY
Sheets("EXTENSION").Select
Dim strColName2 As String
Dim intRng2 As Integer
Dim J As Integer
Dim strVal2 As String
intRng2 = 20 'To get the No. of Columns Available to Search
strColName2 = "Qty" 'To Get the Column Name to Search
strSheetName = "Accubid Extension" 'To get the Sheet Name to paste the content
For J = 1 To intRng2
' Store the Cell Value
strVal2 = Cells(1, J)
'Check the Value with the User given column name
If UCase(strVal2) = UCase(strColName2) Then
' Select and Copy
Cells(1, J).Select
Range(Selection, Selection.End(xlDown).Offset(9997, 0)).Select
Selection.Copy
' Select and Paste
Sheets(strSheetName).Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
'
'
' TOTAL MATERIAL
Sheets("EXTENSION").Select
Dim strColName3 As String
Dim intRng3 As Integer
Dim k As Integer
Dim strVal3 As String
intRng3 = 20 'To get the No. of Columns Available to Search
strColName3 = "Total Mat. $" 'To Get the Column Name to Search
strSheetName = "Accubid Extension" 'To get the Sheet Name to paste the content
For k = 1 To intRng3
' Store the Cell Value
strVal3 = Cells(1, k)
'Check the Value with the User given column name
If UCase(strVal3) = UCase(strColName3) Then
' Select and Copy
Cells(1, k).Select
Range(Selection, Selection.End(xlDown).Offset(9997, 0)).Select
Selection.Copy
' Select and Paste
Sheets(strSheetName).Select
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
'
'
' FIELD LABOR
Sheets("EXTENSION").Select
Dim strColName4 As String
Dim intRng4 As Integer
Dim l As Integer
Dim strVal4 As String
intRng4 = 20 'To get the No. of Columns Available to Search
strColName4 = "Total Field Labor" 'To Get the Column Name to Search
strSheetName = "Accubid Extension" 'To get the Sheet Name to paste the content
For l = 1 To intRng4
' Store the Cell Value
strVal4 = Cells(1, l)
'Check the Value with the User given column name
If UCase(strVal4) = UCase(strColName4) Then
' Select and Copy
Cells(1, l).Select
Range(Selection, Selection.End(xlDown).Offset(9997, 0)).Select
Selection.Copy
' Select and Paste
Sheets(strSheetName).Select
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
'
'
' VIEWPOINT CODES
Sheets("EXTENSION").Select
Dim strColName5 As String
Dim intRng5 As Integer
Dim m As Integer
Dim strVal5 As String
intRng5 = 20 'To get the No. of Columns Available to Search
strColName5 = "Viewpoint Codes" 'To Get the Column Name to Search
strSheetName = "Accubid Extension" 'To get the Sheet Name to paste the content
For m = 1 To intRng5
' Store the Cell Value
strVal5 = Cells(1, m)
'Check the Value with the User given column name
If UCase(strVal5) = UCase(strColName5) Then
' Select and Copy
Cells(1, m).Select
Range(Selection, Selection.End(xlDown).Offset(9997, 0)).Select
Selection.Copy
' Select and Paste
Sheets(strSheetName).Select
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
'
'
' EARNED VALUE
Sheets("EXTENSION").Select
Dim strColName6 As String
Dim intRng6 As Integer
Dim N As Integer
Dim strVal6 As String
intRng6 = 20 'To get the No. of Columns Available to Search
strColName6 = "Earned Value" 'To Get the Column Name to Search
strSheetName = "Accubid Extension" 'To get the Sheet Name to paste the content
For N = 1 To intRng6
' Store the Cell Value
strVal6 = Cells(1, N)
'Check the Value with the User given column name
If UCase(strVal6) = UCase(strColName6) Then
' Select and Copy
Cells(1, N).Select
Range(Selection, Selection.End(xlDown).Offset(9997, 0)).Select
Selection.Copy
' Select and Paste
Sheets(strSheetName).Select
Range("G1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
'
'
'THIS SLOWS THE SHEET DOWN
Application.Calculation = xlAutomatic
'
'
'
' BREAKDOWN_SHEET_PASTE
Sheets("ACCUBID EXTENSION").Select
ActiveSheet.Range("A1:A10000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("x2"), Unique:=True
Range("X3:X800").Select 'THIS WAS X4;X500
'
Sheets("ACCUBID EXTENSION").Select
Range("X3:X800").Select
ActiveWorkbook.Worksheets("ACCUBID EXTENSION").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ACCUBID EXTENSION").Sort.SortFields.Add Key:=Range _
("X3:X800"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ACCUBID EXTENSION").Sort
.SetRange Range("X3:X800")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
'
Sheets("BID BREAKDOWN").Select
ActiveSheet.Unprotect "PRECON"
Sheets("Accubid Extension").Select
Range("X4:X800").Select
Selection.Copy
Sheets("BID BREAKDOWN").Select
Range("BM4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'
'
'
' SEPERATE CONCATENATED BID BREAKDOWN LABELS
Sheets("ACCUBID EXTENSION").Select
Range("X3:X800").Select
Selection.TextToColumns Destination:=Range("AK2"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=True, Tab:=True, Semicolon _
:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="*", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True
' DELETE "||"
Sheets("ACCUBID EXTENSION").Select
Range("AK3:AM10000").Select
Selection.Replace What:="|", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'
'
'
' BREAKDOWN #1_SHEET_PASTE
Sheets("ACCUBID EXTENSION").Select
Range("AK3:AK799").Select
Selection.Copy
Sheets("BID BREAKDOWN").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'
'
'
' BREAKDOWN #2_SHEET_PASTE
Sheets("ACCUBID EXTENSION").Select
Range("AL3:AL799").Select
Selection.Copy
Sheets("BID BREAKDOWN").Select
Range("C4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'
'
'
'' BREAKDOWN #3_SHEET_PASTE
Sheets("ACCUBID EXTENSION").Select
Range("AM3:AM799").Select
Selection.Copy
Sheets("BID BREAKDOWN").Select
Range("D4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("E:E").Select
Selection.EntireColumn.Hidden = True
'
'
'
'
Sheets("EXTENSION").Select
Range("A1").Select
'
'
'
Sheets("ACCUBID EXTENSION").Select
ActiveSheet.Protect "PRECON"
'
'
'
Sheets("ACCUBID EXTENSION").Visible = False
Sheets("% LABOR CURVE").Visible = True
'
'
'
Sheets("PRODUCTIVITY").Select
ActiveSheet.Unprotect "PRECON"
ActiveSheet.Range("$HX$1:$HX$400").AutoFilter Field:=1
ActiveSheet.Range("$HX$1:$HX$400").AutoFilter Field:=1, Criteria1:="1"
Dim vWs As Worksheet
Set vWs = Application.ActiveSheet
Dim vPws As String
vPws = "PRECON"
vWs.Protect Password:=vPws, userinterfaceonly:=True
vWs.EnableOutlining = True
Range("A1").Select
'
'
'
Sheets("RECAP").Select
'
'
'
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
'
'
'
End Sub
Display More