VBA Read dates

[Andyb2]

Hi all,

I have created a macro below using the recording function.

A) My macro code is quite long and I wanted to shorten it if possible, the main thing is when I highlight all the column to then make the table takes up lots of space?
B) I would like to convert the financial year dates as listed below to ordinary year dates. For example, in column AM I would like it to display (2018 04 as December 2018) and (2019 03 as 2019). The year and period are listed in column Q and R. However, i'm not sure the code to add, please can you help.

• 2018 04 – December 2018
• 2018 05 – January 2019
• 2018 06 – February 2019
• 2018 07 – March 2019
• 2018 08 – April 2019
• 2018 10 – May 2019
• 2018 11- June 2019
• 2018 12- July 2019
• 2019 01 – August 2019
• 2019 02 – September 2019
• 2019 03 – October 2019
• 2019 04 – November 2019
• 2019 05 – December 2019
• 2019 06 – January 2020

Sub Andy_New_Macro_2()

'

' Andy_New_Macro_2 Macro

'



'

Sheets("_Keywords").Select

ActiveWindow.SelectedSheets.Visible = False

Sheets("Customer Funder Account Mapping").Select

ActiveWindow.SelectedSheets.Visible = False

Sheets("Exchange Rate Query RMID - King").Select

ActiveWindow.SelectedSheets.Visible = False

Sheets("RESPROJ Budget Load Summary").Select

ActiveWindow.SelectedSheets.Visible = False

ActiveWindow.ScrollWorkbookTabs Sheets:=-1

ActiveWindow.ScrollWorkbookTabs Sheets:=-1

Sheets("RESPROJ Budget Load Check").Select

ActiveWindow.SelectedSheets.Visible = False

Sheets("Standard Browser Enquiry POST A").Select

Columns("A:A").Select

Selection.Delete Shift:=xlToLeft

Rows("1:1").Select

Selection.Delete Shift:=xlUp

Range("B8").Select

Application.CutCopyMode = False

ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$AL"), , xlYes).Name = _

"Table1"

Columns("A:AL").Select

ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight1"

ActiveWindow.ScrollColumn = 28

ActiveWindow.ScrollColumn = 27

ActiveWindow.ScrollColumn = 26

ActiveWindow.ScrollColumn = 25

ActiveWindow.ScrollColumn = 24

ActiveWindow.ScrollColumn = 23

ActiveWindow.ScrollColumn = 22

ActiveWindow.ScrollColumn = 21

ActiveWindow.ScrollColumn = 20

ActiveWindow.ScrollColumn = 19

ActiveWindow.ScrollColumn = 18

ActiveWindow.ScrollColumn = 17

ActiveWindow.ScrollColumn = 16

ActiveWindow.ScrollColumn = 15

ActiveWindow.ScrollColumn = 14

ActiveWindow.ScrollColumn = 13

ActiveWindow.ScrollColumn = 12

ActiveWindow.ScrollColumn = 11

ActiveWindow.ScrollColumn = 10

ActiveWindow.ScrollColumn = 11

ActiveWindow.ScrollColumn = 12

ActiveWindow.ScrollColumn = 13

ActiveWindow.ScrollColumn = 14

ActiveWindow.ScrollColumn = 15

ActiveWindow.ScrollColumn = 16

ActiveWindow.ScrollColumn = 17

ActiveWindow.ScrollColumn = 18

ActiveWindow.ScrollColumn = 19

ActiveWindow.ScrollColumn = 20

ActiveWindow.ScrollColumn = 21

ActiveWindow.ScrollColumn = 22

ActiveWindow.ScrollColumn = 21

ActiveWindow.ScrollColumn = 20

ActiveWindow.ScrollColumn = 19

ActiveWindow.ScrollColumn = 18

ActiveWindow.ScrollColumn = 17

ActiveWindow.ScrollColumn = 16

ActiveWindow.ScrollColumn = 15

Range("R4").Select

ActiveWorkbook.Worksheets("Standard Browser Enquiry POST A").ListObjects( _

"Table1").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Standard Browser Enquiry POST A").ListObjects( _

"Table1").Sort.SortFields.Add2 Key:=Columns("R:R"), SortOn:=xlSortOnValues _

, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Standard Browser Enquiry POST A").ListObjects( _

"Table1").Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Sheets("Standard Browser Enquiry POST A").Select

Sheets("Standard Browser Enquiry POST A").Name = "R03 Transactions"

Sheets("Summary").Select

Sheets("Summary").Name = "R05 Summary"

Range("D12").Select

Sheets("R03 Transactions").Select

Columns("O:O").ColumnWidth = 19.47

Columns("O:O").ColumnWidth = 29.07

Columns("O:O").ColumnWidth = 36.4

 

[maabadi]

Welcome to MrExcel Message Board.
Please upload your example file & Desired Results with XL2BB ADDIN at above of reply section OR upload it at free uploading site e.g. www.dropbox.com or googledrive or onedrive and insert link here.

 

[Andyb2]

Work template.xlsx Sorry here is a link

 

[maabadi]

This is formula. Why your file is very Slow?
I also work on VBA.

=TEXT((RIGHT([@Period],2)+8)*29,"mmmm") & " " & IF(RIGHT([@Period],2)*1<5,[@Year],[@Year]+1)

 

[Andyb2]

Thanks that was quick! should I insert this at the the end of my VBA code? As I wanted it to run every time I open different sheets and run the macro.

 

[maabadi]

This is Macro:

Sub Test()
 Dim i As Long, Lr As Long, Cell As Range, Sh1 As Worksheet, K As String
 Dim L As Long
 Lr = Range("Q" & Rows.Count).End(xlUp).Row
 Range("S2:S" & Lr).NumberFormat = "@"
 For i = 2 To Lr
 K = Application.WorksheetFunction.Text(Right(Range("R" & i).Value, 2) * 29, "mmmm")
 If Right(Range("R" & i).Value, 2) < 5 Then
  L = Range("Q" & i).Value
  Else
  L = Range("Q" & i).Value + 1
 End If
 Range("S" & i).Value = K & " " & L
 Next i
 
End Sub

 

[maabadi]

Sorry I forgot Change Column S to AM

Sub Test()
 Dim i As Long, Lr As Long, Cell As Range, Sh1 As Worksheet, K As String
 Dim L As Long
 Lr = Range("Q" & Rows.Count).End(xlUp).Row
 Range("AM2:AM" & Lr).NumberFormat = "@"
 For i = 2 To Lr
 K = Application.WorksheetFunction.Text(Right(Range("R" & i).Value, 2) * 29, "mmmm")
 If Right(Range("R" & i).Value, 2) < 5 Then
  L = Range("Q" & i).Value
  Else
  L = Range("Q" & i).Value + 1
 End If
 Range("AM" & i).Value = K & " " & L
 Next i
 
End Sub

 

[Andyb2]

Thanks I tried to paste this VBA code but nothing seems to happen in column AM when I click run?

 

[maabadi]

Are your Sheet was Activesheet?
For me working without problem.

 

[Andyb2]

I tried it on this sheet i've uploaded here work template updated.xlsx

It does the first step of the macro but it doesn't add the date. Sorry I am not sure what you mean by active sheet I'm a beginner.