Reputation: 87
I have made a program, that allows the user to enter the year and team, that they are on. It print the values to a data sheet. When the user click on a commandbutton, the code will print the values to a calendar. My question is, can this be made smarter?
If Worksheets("DATA").Range("B2").Value = "2018" And Worksheets("DATA").Range("B3").Value = "Team 3" Then
'January
Worksheets("Sheet1").Range("J4:J34").Copy
Worksheets("2018").Range("D3:D33").PasteSpecial xlValues
'February
Worksheets("Sheet1").Range("J35:J62").Copy
Worksheets("2018").Range("H3:H33").PasteSpecial xlValues
'March
Worksheets("Sheet1").Range("J63:J93").Copy
Worksheets("2018").Range("L3:L33").PasteSpecial xlValues
'April
Worksheets("Sheet1").Range("J94:J123").Copy
Worksheets("2018").Range("P3:P33").PasteSpecial xlValues
'May
Worksheets("Sheet1").Range("J124:J154").Copy
Worksheets("2018").Range("T3:T33").PasteSpecial xlValues
'June
Worksheets("Sheet1").Range("J155:J184").Copy
Worksheets("2018").Range("X3:X33").PasteSpecial xlValues
'July
Worksheets("Sheet1").Range("J185:J215").Copy
Worksheets("2018").Range("AB3:AB33").PasteSpecial xlValues
'August
Worksheets("Sheet1").Range("J216:J246").Copy
Worksheets("2018").Range("AF3:AF33").PasteSpecial xlValues
'September
Worksheets("Sheet1").Range("J247:J276").Copy
Worksheets("2018").Range("AJ3:AJ33").PasteSpecial xlValues
'October
Worksheets("Sheet1").Range("J277:J307").Copy
Worksheets("2018").Range("AN3:AN33").PasteSpecial xlValues
'November
Worksheets("Sheet1").Range("J308:J337").Copy
Worksheets("2018").Range("AR3:AR33").PasteSpecial xlValues
'December
Worksheets("Sheet1").Range("J338:J368").Copy
Worksheets("2018").Range("AV3:AV33").PasteSpecial xlValues
End If
On the Sheet1 sheet, the dates are listed in C
Upvotes: 0
Views: 2471
Reputation: 10715
You can try to make it easier to update the ranges to be copied (mapping):
Option Explicit
Public Sub CopyData()
Const START_ROW = 3
If ThisWorkbook.Worksheets("DATA").Range("B2").Value = "2018" And _
ThisWorkbook.Worksheets("DATA").Range("B3").Value = "Team 3" Then
Dim yr As Object, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("2018")
Set yr = CreateObject("Scripting.Dictionary")
yr("J4:J34") = "D" 'Jan
yr("J35:J62") = "H" 'Feb
yr("J63:J93") = "L" 'Mar
yr("J94:J123") = "P" 'Apr
yr("J124:J154") = "T" 'May
yr("J155:J184") = "X" 'Jun
yr("J185:J215") = "AB" 'Jul
yr("J216:J246") = "AF" 'Aug
yr("J247:J276") = "AJ" 'Sep
yr("J277:J307") = "AN" 'Oct
yr("J308:J337") = "AR" 'Nov
yr("J338:J368") = "AV" 'Dec
Dim mnth As Variant, arr As Variant, toRng As String
For Each mnth In yr
arr = ws1.Range(mnth)
toRng = yr(mnth) & START_ROW & ":" & yr(mnth) & UBound(arr) + START_ROW - 1
ws2.Range(toRng) = arr
Next mnth
End If
End Sub
This is not ideal because there are still hard-coded values for all ranges but the columns are not the same size and I can't see the pattern for that
Upvotes: 1
Reputation: 22876
Because date and time in Excel is stored as a number of days, the source row can be found with:
=Date(2018, Column() / 4, Row()) - Date(2018, 1, -1)
and the source column index with:
=Match(Data!B3 & "*", '2018'!3:3, 0)
and combined in VBA:
y = [DATA!B2]
Sheet1.[3:33 (D:D,H:H,L:L,P:P,T:T,X:X,AB:AB,AF:AF,AJ:AJ,AN:AN,AR:AR,AV:AV)].Formula = _
"=If(C3, Index('" & y & "'!$A:$Z, Date(" & y & ", Column() / 4, Row()) - Date(" & y _
& ", 1, -1), " & Evaluate("Match(DATA!B3 & ""*"", '" & y & "'!3:3, 0)") & " ), """")"
Upvotes: 0