Asset register report - macro

L

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:

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
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
 
Upvote 0
Hi,

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

Thanks a lot
Lakshmipathi
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Slow Macro
Replies
3
Views
217
Philip1957
P
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
208
Coco1
C
L
  • Solved
VBA SaveAs
Replies
3
Views
265
Joe4
Joe4
R
  • Question
Extract rows based upon unique data in first column of an array
Replies
2
Views
208
RJC40
R
I
  • Question
Error in using VBA Macro with Apply Colors and Line Numbers
Replies
3
Views
108
intellitechdataservices
I

Forum statistics

Threads
1,214,935
Messages
6,122,337
Members
449,077
Latest member
Jocksteriom

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