Any way to simplify the code

L

lemonboy

New Member
Joined
Apr 8, 2022
Messages
2
Office Version
  1. 365
Platform
  1. Windows
hi,

this there any way to simplify my code below

VBA Code: 
Sub CN()

Dim SheetName As String
Dim LR As Long
Dim lngLastRow As Long
Dim LastRow1 As Long
Dim Source_Workbook As Workbook
Set Source_Workbook = ThisWorkbook

    Sheets("Inventory").Select
 
    ActiveSheet.UsedRange.AutoFilter Field:=2, Criteria1:="CN"
    ActiveSheet.UsedRange.AutoFilter Field:=15, Criteria1:="ACTIVE"
   
        Range("a1").Select
        ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
        Selection.Copy
       
            SheetName = ("CN")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName

            ActiveSheet.Paste
            Application.CutCopyMode = False
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange"
            ActiveSheet.ListObjects.Add(xlSrcRange, Range("TRange"), , xlYes).Name = SheetName
            ActiveWorkbook.Sheets(SheetName).ListObjects(SheetName).ListColumns.Add.Name = "Service By"
            Range("AG2").Formula = "=VLOOKUP(W2,'Service By For CN'!A:B,2,FALSE)"
           
            ActiveWorkbook.Sheets(SheetName).ListObjects(SheetName).ListColumns.Add.Name = Sheets("Location mapping For CN").Range("b1").Value
            Range("AH2").Formula = "=VLOOKUP(AC2,'Location mapping For CN'!A:D,2,FALSE)"
           
            ActiveWorkbook.Sheets(SheetName).ListObjects(SheetName).ListColumns.Add.Name = Sheets("Location mapping For CN").Range("c1").Value
            Range("AI2").Formula = "=VLOOKUP(AC2,'Location mapping For CN'!A:D,3,FALSE)"
           
            ActiveWorkbook.Sheets(SheetName).ListObjects(SheetName).ListColumns.Add.Name = Sheets("Location mapping For CN").Range("d1").Value
            Range("AJ2").Formula = "=VLOOKUP(AC2,'Location mapping For CN'!A:D,4,FALSE)"

            ActiveWorkbook.Sheets(SheetName).ListObjects(SheetName).ListColumns.Add.Name = "Final tab - Column B "
            lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
           
            Range("AK2:AK" & lngLastRow).Formula = "=""/""& AG2 & ""/"" & w2& ""/"""
            ActiveWorkbook.Sheets(SheetName).ListObjects(SheetName).ListColumns.Add.Name = "MTM"
           
            Range("AL2:AL" & lngLastRow).Formula = "=VLOOKUP(S2,'MTM For CN'!A:B,2,FALSE)"
            Range("AG2:AL" & lngLastRow).Copy
            Range("AG2").PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
           
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=33, Criteria1:="M"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName1 = ("MVS")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName1
            ActiveSheet.Paste
            Application.CutCopyMode = False
            ActiveSheet.Range("A1").Select
            Columns("AL").Delete
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
           
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=33, Criteria1:="F"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName2 = ("Futong")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName2
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Columns("AL").Delete
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
           
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=33, Criteria1:="L"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName3 = ("Lanbaili")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName3
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Columns("AL").Delete
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
           
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=33, Criteria1:="A"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName4 = ("Anchit")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName4
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Columns("AL").Delete
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
           
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=33, Criteria1:="M"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName5 = ("Mingde")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName5
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Columns("AL").Delete
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
           
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=33, Criteria1:="BP"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName6 = ("BP")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName6
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Columns("AL").Delete
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
               
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=7, Criteria1:="SERVICE"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName7 = ("Service Desk MA")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName7
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
           
            ActiveSheet.ListObjects(SheetName).Range.AutoFilter Field:=7, Criteria1:="WARRANTY"
            ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Select
            Selection.Copy
            SheetName8 = ("Service Desk WA")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName8
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Sheets(SheetName).Select
            ActiveSheet.ListObjects(SheetName).AutoFilter.ShowAllData
                       
            SheetName9 = ("ServiceDesk")
            Sheets.Add After:=ActiveSheet
            ActiveSheet.Name = SheetName9
            Worksheets("MTM For CN").Range("F1:AA1").Copy Worksheets(SheetName9).Range("A1")
                       
            Sheets(SheetName7).Columns.Range("T2:T" & lngLastRow).Copy Sheets(SheetName9).Range("E2")
            Sheets(SheetName7).Columns.Range("AK2:AK" & lngLastRow).Copy Sheets(SheetName9).Range("G2")
            Sheets(SheetName7).Columns.Range("AH2:AJ" & lngLastRow).Copy Sheets(SheetName9).Range("I2")
            Sheets(SheetName7).Columns.Range("AC2:AC" & lngLastRow).Copy Sheets(SheetName9).Range("L2")
            Sheets(SheetName7).Columns.Range("V2:V" & lngLastRow).Copy Sheets(SheetName9).Range("O2")
            Sheets(SheetName7).Columns.Range("G2:G" & lngLastRow).Copy Sheets(SheetName9).Range("P2")
            Sheets(SheetName7).Columns.Range("P2:Q" & lngLastRow).Copy Sheets(SheetName9).Range("S2")
            Sheets(SheetName7).Columns.Range("AE2:AE" & lngLastRow).Copy Sheets(SheetName9).Range("V2")
            Sheets(SheetName7).Columns.Range("AL2:AL" & lngLastRow).Copy
            Sheets(SheetName9).Range("B2").PasteSpecial Paste:=xlPasteValues
           
            LR = Cells(Rows.Count, 5).End(xlUp).Row
            Sheets(SheetName8).Columns.Range("T2:T" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "E")
            Sheets(SheetName8).Columns.Range("AK2:AK" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "G")
            Sheets(SheetName8).Columns.Range("AH2:AJ" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "I")
            Sheets(SheetName8).Columns.Range("AC2:AC" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "L")
            Sheets(SheetName8).Columns.Range("V2:V" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "O")
            Sheets(SheetName8).Columns.Range("G2:G" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "P")
            Sheets(SheetName8).Columns.Range("P2:Q" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "Q")
            Sheets(SheetName8).Columns.Range("AE2:AE" & lngLastRow).Copy Destination:=Sheets(SheetName9).Cells(LR + 1, "U")
            Sheets(SheetName8).Columns.Range("AL2:AL" & lngLastRow).Copy
            Sheets(SheetName9).Cells(LR + 1, "B").PasteSpecial Paste:=xlPasteValues
                       
            Range("c2:c" & Cells(Rows.Count, "B").End(xlUp).Row).Formula = "=VLOOKUP(b2,'MTM For CN'!b:D,2,FALSE)"
            Range("d2:d" & Cells(Rows.Count, "B").End(xlUp).Row).Formula = "=VLOOKUP(b2,'MTM For CN'!b:D,3,FALSE)"
            Range("c2:D" & lngLastRow).Copy
            Range("c2").PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False

            LastRow1 = Range("L" & Rows.Count).End(xlUp).Row
            Range("A2") = Worksheets("MTM For CN").Range("F2"): Range("A2:A" & LastRow1).FillDown
            Range("F2") = Worksheets("MTM For CN").Range("K2"): Range("F2:F" & LastRow1).FillDown
            Range("H2") = Worksheets("MTM For CN").Range("M2"): Range("H2:H" & LastRow1).FillDown
           
            ActiveSheet.UsedRange.Select
            Selection.Name = "TRange1"
            Range("TRange1").Borders.LineStyle = xlContinuous
            Range("TRange1").WrapText = True
            Range("TRange1").EntireRow.RowHeight = 30
            Range("TRange1").EntireColumn.ColumnWidth = 15
                     
           
            Application.DisplayAlerts = False
            Sheets(SheetName7).Delete
            Sheets(SheetName8).Delete
            Application.DisplayAlerts = True
           
           
            ActiveWorkbook.Worksheets(SheetName).ListObjects(SheetName).ListColumns("MTM").Delete
           
           
            Sheets(Array(SheetName9, SheetName6, SheetName5, SheetName4, SheetName3, SheetName2, SheetName1, SheetName)).Move
           
                Dim PSheet As Worksheet
                Dim DSheet As Worksheet
                Dim PCache As PivotCache
                Dim PTable As PivotTable
                Dim PRange As Range
                Dim LastRow As Long
                Dim LastCol As Long
               
                On Error Resume Next
                Application.DisplayAlerts = False
                Sheets.Add After:=ActiveSheet
                ActiveSheet.Name = "ServicedByPivot"
                Application.DisplayAlerts = True
                Set PSheet = Worksheets("ServicedByPivot")
                Set DSheet = Worksheets(SheetName)
             
             
                LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
                LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
                Set PRange = DSheet.Cells(1, 1).Resize(LastRow, LastCol)
               
                Set PCache = ActiveWorkbook.PivotCaches.Create _
                (SourceType:=xlDatabase, SourceData:=PRange). _
                CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
                TableName:="ServicedByPivot")
               
                Set PTable = PCache.CreatePivotTable _
                (TableDestination:=PSheet.Cells(1, 1), TableName:="ServicedByPivot")
               
                             
                    With ActiveSheet.PivotTables("ServicedByPivot").PivotFields("Service By")
                    .Orientation = xlColumnField
                    .Position = 1
                    End With
                        With ActiveSheet.PivotTables("ServicedByPivot").PivotFields("Install Owner")
                        .Orientation = xlRowField
                        .Position = 1
                        End With
                        ActiveSheet.PivotTables("ServicedByPivot").AddDataField ActiveSheet.PivotTables( _
                        "ServicedByPivot").PivotFields("Serial Number"), "Count of Serial Number", xlCount
                       
                Range("b1").EntireColumn.ColumnWidth = 49
                       
  
                On Error Resume Next
                Application.DisplayAlerts = False
                Sheets.Add After:=ActiveSheet
                ActiveSheet.Name = "LocationPivot"
                Application.DisplayAlerts = True
                Set PSheet = Worksheets("LocationPivot")
                Set DSheet = Worksheets(SheetName)
             

                Set PCache = ActiveWorkbook.PivotCaches.Create _
                (SourceType:=xlDatabase, SourceData:=PRange). _
                CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
                TableName:="LocationPivot")
               
                Set PTable = PCache.CreatePivotTable _
                (TableDestination:=PSheet.Cells(1, 1), TableName:="LocationPivot")
               
                  
                        With ActiveSheet.PivotTables("LocationPivot").PivotFields("Install Address")
                        .Orientation = xlRowField
                        .Position = 1
                        End With
                       
                       
                        ActiveSheet.PivotTables("LocationPivot").AddDataField ActiveSheet.PivotTables( _
                        "LocationPivot").PivotFields("Serial Number"), "Count of Serial Number", xlCount
                       
            Range("b1").EntireColumn.ColumnWidth = 100
           

           
           
                Source_Workbook.Activate
                Sheets("Inventory").Select
                If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData
                Sheets("GenerateRep").Select
               
               
End Sub
 
Last edited by a moderator:

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
Firstly, you can split the code into several procedure
Secondly, On error Resume Next can be wrote on the beginning, and which is worked in the whole Sub
Thirdly, Use With structure as many as possible
 
Upvote 0
LastRow1 = Range("L" & Rows.Count).End(xlUp).Row
which as same as below code
LastRow1 = [L1].End(xlUp).Row
 
Upvote 0
Application.DisplayAlerts doesn't matter, you can close it in the beginning
 
Upvote 0
TUY said:
Range("L" & Rows.Count).End(xlUp).Row
Click to expand...
using ur code it become this
1649400600747.png


is use the orginal code is ok
1649400740033.png
 

Attachments

  • 1649400672003.png
    1649400672003.png
    13.2 KB · Views: 8
Upvote 0
TUY said:
Secondly, On error Resume Next can be wrote on the beginning, and which is worked in the whole Sub
Click to expand...
Beg to differ, Error handling should not be applied to a whole sub. It should be ended once the error point that is expected has passed or the code written to avoid the error in the first place.

One issue with the code posted as far as the On Error Resume next is concerned is there is no On Error Goto 0 to reset the error handler between the On Error Resume Next statements.

TUY said:
LastRow1 = Range("L" & Rows.Count).End(xlUp).Row
which as same as below code
LastRow1 = [L1].End(xlUp).Row
Click to expand...
No it isn't
 
Upvote 0
MARK858 said:
Beg to differ, Error handling should not be applied to a whole sub. It should be ended once the error point that is expected has passed or the code written to avoid the error in the first place.

One issue with the code posted as far as the On Error Resume next is concerned is there is no On Error Goto 0 to reset the error handler between the On Error Resume Next statements.


No it isn't
Click to expand...
What‘s the difference
 
Upvote 0
TUY said:
What‘s the difference
Click to expand...

VBA Code: 
LastRow1 = Range("L" & Rows.Count).End(xlUp).Row
Looks from the bottom of the sheet in column L upwards until it finds the row with the last cell with data
VBA Code: 
LastRow1 = [L1].End(xlUp).Row
looks from cell L1 upwards so returns 1 always

put some data in column L and run the below

VBA Code: 
Sub xxxxx()
MsgBox Range("L" & Rows.Count).End(xlUp).Row
MsgBox [L1].End(xlUp).Row
End Sub
 
Upvote 0
MARK858 said:
Beg to differ, Error handling should not be applied to a whole sub. It should be ended once the error point that is expected has passed or the code written to avoid the error in the first place.

One issue with the code posted as far as the On Error Resume next is concerned is there is no On Error Goto 0 to reset the error handler between the On Error Resume Next statements.


No it isn't
Click to expand...

MARK858 said:
Beg to differ, Error handling should not be applied to a whole sub. It should be ended once the error point that is expected has passed or the code written to avoid the error in the first place.

One issue with the code posted as far as the On Error Resume next is concerned is there is no On Error Goto 0 to reset the error handler between the On Error Resume Next statements.


No it isn't
Click to expand...
Attached photo is my associate's code, and which have operated well for two yearsUntitled.png
 
Upvote 0
Sorry, I make the wrong direction. Is LastRow1 = [L1].End(xldown).Row right?
MARK858 said:
VBA Code: 
LastRow1 = Range("L" & Rows.Count).End(xlUp).Row
Looks from the bottom of the sheet in column L upwards until it finds the row with the last cell with data
VBA Code: 
LastRow1 = [L1].End(xlUp).Row
looks from cell L1 upwards so returns 1 always

put some data in column L and run the below

VBA Code: 
Sub xxxxx()
MsgBox Range("L" & Rows.Count).End(xlUp).Row
MsgBox [L1].End(xlUp).Row
End Sub[/CODE
[/QUOTE]
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA to loop through sheets and copy to new workbook including the pivot tab
Replies
0
Views
392
simont1975
S
willow1985
  • Solved
Find first blank cell in column A in a Table - Runtime error 91
Replies
4
Views
399
willow1985
willow1985
M
  • Question Question
Table issue with VBA
Replies
2
Views
405
Mike2
M
I
  • Solved
Simplify my working code please
Replies
7
Views
186
ipbr21054
I
G
  • Question Question
VBA help - copy cells from specific table to specific table on another sheet.
Replies
0
Views
763
GardianAngelUK
G

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top