Question

我制作了一个程序，允许用户输入他们所在的年份和团队。它将值打印到数据表。当用户单击命令按钮时，代码会将值打印到日历。我的问题是，这可以变得更聪明吗？

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

在Sheet1表上，日期列在C

中

Answer 1

您可以尝试更新更新要复制的范围（映射）：

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

这不太理想，因为所有范围仍然存在硬编码值，但列的大小不同，我无法看到该模式

Answer 2

由于Excel中的日期和时间存储为天数，因此可以在以下位置找到源行：

=Date(2018, Column() / 4, Row()) - Date(2018, 1, -1)

和源列索引：

=Match(Data!B3 & "*", '2018'!3:3, 0)

并在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)") & " ), """")"

VBA复制范围值并粘贴到另一个工作表中

2 个答案: