Asset register report - macro

lakshmipathi123

Board Regular
Joined
Jul 10, 2012
Messages
52
Office Version
  1. 365
Platform
  1. Windows
Hi Experts,

Pls find below codings for Fixed asset register. it is working fine but i feel slow. Kindly advice on following
1. Speed up my macro
2. Is there any suggestions or modifications to make short codings instead of 2 pages of macro.
Code:
Sub UFAR()
'
' UFAR Macro
'
Dim dLastRow As Double


    dLastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
    Rows("1:11").Select
    Selection.EntireRow.Delete
    dLastRow = dLastRow - 11
    Range("A1:A5").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(185, 1), Array(551, 1)), TrailingMinusNumbers _
        :=True
    Range("A1:D4").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A2").Select
    ActiveSheet.Paste
    Sheets("Main").Select
    Rows("1:5").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Range(Selection, Cells(dLastRow, 1)).Select


    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(17, 1), Array(18, 1), Array(31, 1), Array(32, 1), _
        Array(62, 1), Array(63, 1), Array(67, 1), Array(68, 1), Array(84, 1), Array(85, 1), Array( _
        99, 1), Array(100, 1), Array(114, 1), Array(115, 1), Array(131, 1), Array(132, 1), Array( _
        146, 1), Array(147, 1), Array(156, 1), Array(157, 1), Array(160, 1), Array(161, 1), Array( _
        165, 1), Array(166, 1), Array(174, 1), Array(175, 1), Array(183, 1), Array(184, 1), Array( _
        194, 1), Array(195, 1), Array(201, 1), Array(202, 1), Array(232, 1), Array(233, 1), Array( _
        263, 1), Array(264, 1), Array(269, 1), Array(270, 1), Array(274, 1), Array(275, 1), Array( _
        280, 1), Array(281, 1), Array(285, 1), Array(286, 1), Array(292, 1), Array(293, 1), Array( _
        297, 1), Array(298, 1), Array(318, 1), Array(319, 1), Array(349, 1), Array(350, 1), Array( _
        352, 1), Array(353, 1), Array(383, 1), Array(384, 1), Array(404, 1), Array(405, 1), Array( _
        417, 1), Array(418, 1), Array(422, 1), Array(423, 1), Array(453, 1), Array(454, 1), Array( _
        462, 1), Array(463, 1), Array(469, 1), Array(470, 1), Array(480, 1), Array(481, 1), Array( _
        491, 1), Array(492, 1), Array(504, 1), Array(505, 1), Array(515, 1), Array(516, 1), Array( _
        526, 1), Array(527, 1), Array(543, 1), Array(544, 1), Array(554, 1), Array(555, 1), Array( _
        585, 1), Array(586, 1), Array(616, 1), Array(617, 1), Array(647, 1), Array(648, 1), Array( _
        678, 1), Array(679, 1), Array(714, 1), Array(715, 1)), TrailingMinusNumbers:=True
    
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    
    Range("A1").Select
    Do Until ActiveCell = ""
        If ActiveCell = "|" Then
            ActiveCell.EntireColumn.Delete
            ActiveCell.Offset(0, -1).Select
        End If
            ActiveCell.Offset(0, 1).Select
    Loop
        
    With Selection.Font
        .name = "Arial"
        .Size = 9
    End With
    
    Rows("2:2").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Font.Bold = True
       With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
       End With
    
    Columns("K:K").Select
    Selection.Insert Shift:=xlToRight
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "End Date"
    
    With Range("K2:K" & Range("J" & Rows.count).End(xlUp).Row)
    .FormulaR1C1 = "=IFERROR(EOMONTH(RC[-1],RC[2]-1),"""")"
    .Value = .Value
    End With
    
    Columns("Y:Y").Select
    Selection.Insert Shift:=xlToRight
    Range("Y1").Select
    ActiveCell.FormulaR1C1 = "BU"
    
    With Range("Y2:Y" & Range("X" & Rows.count).End(xlUp).Row)
    .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],BU!C[-22]:C[-16],7,0),"""")"
                    
    .Value = .Value
   End With
   
   Columns("AG:AG").Select
    Selection.Insert Shift:=xlToRight
    Range("AG1").Select
    ActiveCell.FormulaR1C1 = "Project Name"
    
    With Range("AG2:AG" & Range("AF" & Rows.count).End(xlUp).Row)
    .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],Projects!C[-32]:C[-31],2,0),"""")"
                    
    .Value = .Value
   End With
   
   Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    With Selection
    .HorizontalAlignment = xlGeneral
    .HorizontalAlignment = xlLeft
    End With
   
   Range("E:I,J:M,Q:Q,X:Y,Z:Z,AK:AK").Select
   With Selection
        .HorizontalAlignment = xlCenter
    End With
    
    Columns("AH:AH").Select
    With Selection
        .HorizontalAlignment = xlRight
    End With
       
    Range("B:B", "T:T").Select
    Application.CutCopyMode = False
    Selection.NumberFormat = "General"
    
    Columns("E:I").Select
    Selection.Style = "Comma"
    
    Columns("J:K").Select
    Selection.NumberFormat = "[$-409]dd-mmm-yy;@"
    
    Columns("AK:AK").Select
    Selection.NumberFormat = "[$-409]mmm-yy;@"
            
    Cells.Select
    Columns.AutoFit
    
    Sheets("Main").Select
    Rows("1:5").Select
    Selection.Insert Shift:=xlDown
    Sheets("Sheet2").Select
    Range("A2:C5").Select
    Selection.Copy
    Sheets("Main").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("B1:B4").Select
    Application.CutCopyMode = False
    Selection.Cut
    Range("I1").Select
    ActiveSheet.Paste
    Range("AK2").Select
    Range("C1:C4").Select
    Selection.Cut
    Range("AK1").Select
    ActiveSheet.Paste
    Range("A1").Select
     
End Sub
Thanks in Advance
Lakshmipathi
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

John Davis

Well-known Member
Joined
Sep 11, 2007
Messages
3,457
This is what I came up with, test on a copy first:

Code:
Sub UFAR()
'
' UFAR Macro
'
Dim dLastRow As Double

Application.ScreenUpdating = False


    dLastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
    Rows("1:11").Delete Shift:=xlUp
    dLastRow = dLastRow - 11
    Range("A1:A5").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(185, 1), Array(551, 1)), TrailingMinusNumbers _
        :=True
    Range("A1:D4").Copy Sheets("Sheet2").Range("A2")
    Sheets("Main").Rows("1:5").Delete Shift:=xlUp
    Range("A1").Select
    Range(Selection, Cells(dLastRow, 1)).Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(17, 1), Array(18, 1), Array(31, 1), Array(32, 1), _
        Array(62, 1), Array(63, 1), Array(67, 1), Array(68, 1), Array(84, 1), Array(85, 1), Array( _
        99, 1), Array(100, 1), Array(114, 1), Array(115, 1), Array(131, 1), Array(132, 1), Array( _
        146, 1), Array(147, 1), Array(156, 1), Array(157, 1), Array(160, 1), Array(161, 1), Array( _
        165, 1), Array(166, 1), Array(174, 1), Array(175, 1), Array(183, 1), Array(184, 1), Array( _
        194, 1), Array(195, 1), Array(201, 1), Array(202, 1), Array(232, 1), Array(233, 1), Array( _
        263, 1), Array(264, 1), Array(269, 1), Array(270, 1), Array(274, 1), Array(275, 1), Array( _
        280, 1), Array(281, 1), Array(285, 1), Array(286, 1), Array(292, 1), Array(293, 1), Array( _
        297, 1), Array(298, 1), Array(318, 1), Array(319, 1), Array(349, 1), Array(350, 1), Array( _
        352, 1), Array(353, 1), Array(383, 1), Array(384, 1), Array(404, 1), Array(405, 1), Array( _
        417, 1), Array(418, 1), Array(422, 1), Array(423, 1), Array(453, 1), Array(454, 1), Array( _
        462, 1), Array(463, 1), Array(469, 1), Array(470, 1), Array(480, 1), Array(481, 1), Array( _
        491, 1), Array(492, 1), Array(504, 1), Array(505, 1), Array(515, 1), Array(516, 1), Array( _
        526, 1), Array(527, 1), Array(543, 1), Array(544, 1), Array(554, 1), Array(555, 1), Array( _
        585, 1), Array(586, 1), Array(616, 1), Array(617, 1), Array(647, 1), Array(648, 1), Array( _
        678, 1), Array(679, 1), Array(714, 1), Array(715, 1)), TrailingMinusNumbers:=True
    
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    
    Range("A1").Select
    Do Until ActiveCell = ""
        If ActiveCell = "|" Then
            ActiveCell.EntireColumn.Delete
            ActiveCell.Offset(0, -1).Select
        End If
            ActiveCell.Offset(0, 1).Select
    Loop
        
    With Selection.Font
        .Name = "Arial"
        .Size = 9
    End With
    
    Rows("2:2").Delete Shift:=xlUp
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Font.Bold = True
       With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
       End With
    
    Columns("K:K").Insert Shift:=xlToRight
    Range("K1") = "End Date"
    
    With Range("K2:K" & Range("J" & Rows.Count).End(xlUp).Row)
    .FormulaR1C1 = "=IFERROR(EOMONTH(RC[-1],RC[2]-1),"""")"
    .Value = .Value
    End With
    
    Columns("Y:Y").Insert Shift:=xlToRight
    Range("Y1") = "BU"
    
    With Range("Y2:Y" & Range("X" & Rows.Count).End(xlUp).Row)
    .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],BU!C[-22]:C[-16],7,0),"""")"
    .Value = .Value
    End With
   
    Columns("AG:AG").Insert Shift:=xlToRight
    Range("AG1") = "Project Name"
    
    With Range("AG2:AG" & Range("AF" & Rows.Count).End(xlUp).Row)
    .FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-1],Projects!C[-32]:C[-31],2,0),"""")"
    .Value = .Value
    End With
   
   Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    With Selection
    .HorizontalAlignment = xlGeneral
    .HorizontalAlignment = xlLeft
    End With
   
   Range("E:I,J:M,Q:Q,X:Y,Z:Z,AK:AK").Select
   With Selection
        .HorizontalAlignment = xlCenter
    End With
    
    Columns("AH:AH").HorizontalAlignment = xlRight
       
    Range("B:B", "T:T").NumberFormat = "General"
    
    Columns("E:I").Style = "Comma"
    
    Columns("J:K").NumberFormat = "[$-409]dd-mmm-yy;@"
    
    Columns("AK:AK").NumberFormat = "[$-409]mmm-yy;@"
            
    Cells.Select
    Columns.AutoFit
    
    Sheets("Main").Rows("1:5").Insert Shift:=xlDown
    Sheets("Sheet2").Range("A2:C5").Copy Sheets("Main").Range("A1")
    Range("B1:B4").Cut Range("I1")
    Range("C1:C4").Cut Range("AK1")
    
    Range("A1").Select
    
Application.ScreenUpdating = True
     
End Sub
 

lakshmipathi123

Board Regular
Joined
Jul 10, 2012
Messages
52
Office Version
  1. 365
Platform
  1. Windows
Hi,

Thank you :)...I tested and its working faster than earlier.:):):)

Thanks a lot
Lakshmipathi
 

Watch MrExcel Video

Forum statistics

Threads
1,123,079
Messages
5,599,636
Members
414,326
Latest member
kfg1287

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
Top