使用VBA根据另一个工作表中的值填充单元格

Question

我正在尝试写出以下情况的整洁方法。

工作表A 有一个列表，每个项目的行数都会有所不同。

工作表A中的信息示例。“日历月”列中要使用的数据。

工作表B 跟踪表正在使用工作表A中的列表来填充工作表中的列标题。

我希望脚本使用工作表B顶部的工作表A的每一行中的值（移至下一行之前每行3次）来为表创建标题。

---

Sub TrackingDays()

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Tracking (DAYS)"

Sheets("Tracking (DAYS)").Select
Sheets("Tracking (DAYS)").Range("A3").Select
ActiveCell.Value = "Ref." & Chr(10) & "#"

ActiveCell.Offset(1, 0).Select
ActiveCell.Value = 1

Do Until ActiveCell.Value = 100
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Value = ActiveCell.Offset(-1, 0).Value + 1
Loop

Sheets("Tracking (DAYS)").Range("B3").Select
ActiveCell.Value = "Resource Name"

Sheets("Tracking (DAYS)").Range("C3").Select
ActiveCell.Value = "Resource" & Chr(10) & "Status"

Sheets("Tracking (DAYS)").Range("D3").Select
ActiveCell.Value = "Days Per" & Chr(10) & "Week"

Sheets("Tracking (DAYS)").Range("E3").Select
ActiveCell.Value = "Whole" & Chr(10) & "Contract" & Chr(10) & "Summary" & Chr(10) & "(Forecast)" & Chr(10) & "Calendar"
With ActiveCell.Characters(Start:=1, Length:=20).Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

With ActiveCell.Characters(Start:=23, Length:=38).Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 9
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

Sheets("Tracking (DAYS)").Range("F3").Select
ActiveCell.Value = "Whole" & Chr(10) & "Contract" & Chr(10) & "Summary" & Chr(10) & "(Forecast)" & Chr(10) & "PSA"
With ActiveCell.Characters(Start:=1, Length:=20).Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

With ActiveCell.Characters(Start:=23, Length:=38).Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 9
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

Sheets("Tracking (DAYS)").Range("G3").Select
ActiveCell.Value = "Whole" & Chr(10) & "Contract" & Chr(10) & "Summary" & Chr(10) & "(Actual)" & Chr(10) & "Calendar"
With ActiveCell.Characters(Start:=1, Length:=20).Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

With ActiveCell.Characters(Start:=23, Length:=38).Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 9
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

Dim MonthTitle As Variant
MonthTitle = ActiveCell.Value

Sheets("Project Information & Setup").Select
Sheets("Project Information & Setup").Range("N4").Select
Sheets("Tracking (DAYS)").Select
Sheets("Tracking (DAYS)").Range("H3").Select
Sheets("Project Information & Setup").Select

Do Until IsEmpty(ActiveCell)

    MonthTitle = ActiveCell.Value
    MonthTitle = Format(MonthTitle, "MMM-yy")
    Sheets("Tracking (DAYS)").Select

    ActiveCell.Value = MonthTitle & Chr(10) & "(Forecast)" & Chr(10) & "Calendar"
    ActiveCell.Offset(0, 1).Select
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=8, Length:=19).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With

    ActiveCell.Value = MonthTitle & Chr(10) & "(Forecast)" & Chr(10) & "PSA"
    ActiveCell.Offset(0, 1).Select
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=8, Length:=14).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With

    ActiveCell.Value = MonthTitle & Chr(10) & "(Actual)" & Chr(10) & "Calendar"
    ActiveCell.Offset(0, 1).Select
    With ActiveCell.Characters(Start:=1, Length:=7).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=8, Length:=17).Font
        .Name = "Calibri"
        .FontStyle = "Regular"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With

Sheets("Project Information & Setup").Select
ActiveCell.Offset(1, 0).Select

Loop

Answer 1

我相信以下代码将按您期望的方式工作，它将遍历工作表A，相应地设置日期格式，然后按照工作表B中列A的图片所示，在工作表B中写入标题：

Sub foo()
Dim wsA As Worksheet: Set wsA = Sheets("A")
Dim wsB As Worksheet: Set wsB = Sheets("B")
'above declare and set the worksheet you are working with, amend as required
LastRow = wsA.Cells(wsA.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A in Sheet A
LastCol = 1
For i = 3 To LastRow 'loop through Sheet A starting in Row 3 to last row with data
    Data = Format(wsA.Cells(i, 1).Value, "mmm-yy") 'format date appropriately
    For x = 1 To 3 'loop 3 times as mentioned
        Select Case x
            Case 1
                wsB.Cells(1, LastCol).Value = Data & " (Forecast) Calendar"
            Case 2
                wsB.Cells(1, LastCol).Value = Data & " (Forecast) PSA"
            Case 3
                wsB.Cells(1, LastCol).Value = Data & " (Actual) Calendar"
        End Select
        LastCol = wsB.Cells(1, wsB.Columns.Count).End(xlToLeft).Column + 1
        'get the next free column
    Next x
Next i
End Sub

Answer 2

只是一个想法，如何使其更有效。您可能想改进格式化部分，只是试图说明如何完成格式化。

Option Explicit

Public Sub GenerateHeaders() 
    Dim WsSource As Worksheet
    Set WsSource = ThisWorkbook.Worksheets("SheetA") 'define source worksheet

    Dim WsDestination As Worksheet
    Set WsDestination = ThisWorkbook.Worksheets("SheetB") 'define destination worksheet

    Dim LastRow As Long
    LastRow = WsSource.Cells(WsSource.Rows.Count, "A").End(xlUp).Row 'find last used row in column A

    Const FirstRow As Long = 2 'first row with data (because of header)

    Dim ActColumn As Long

    Dim iRow As Long
    For iRow = FirstRow To LastRow
        ActColumn = (iRow - (FirstRow - 1)) * 3 - 2
        With WsDestination.Cells(1, ActColumn)
            .Value = WsSource.Cells(iRow, "A").Text & vbLf & "(Forecast)" & vbLf & "Calendar"
            .Font.Size = 9
            .Characters(Start:=1, Length:=Len(WsSource.Cells(iRow, "A").Text)).Font.Size = 11
        End With

        With WsDestination.Cells(1, ActColumn).Offset(0, 1)
            .Value = WsSource.Cells(iRow, "A").Text & vbLf & "(Forecast)" & vbLf & "PSA"
            .Font.Size = 9
            .Characters(Start:=1, Length:=Len(WsSource.Cells(iRow, "A").Text)).Font.Size = 11
        End With

        With WsDestination.Cells(1, ActColumn).Offset(0, 2)
            .Value = WsSource.Cells(iRow, "A").Text & vbLf & "(Actual)" & vbLf & "Calendar"
            .Font.Size = 9
            .Characters(Start:=1, Length:=Len(WsSource.Cells(iRow, "A").Text)).Font.Size = 11
        End With
    Next iRow

End Sub

请注意，我使用WsSource.Cells(iRow, "A").Text来获取原始工作表的日期，其格式必须与原始工作表的格式完全相同。如果要更改，则需要类似Format(WsSource.Cells(iRow, "A").Value, "mmm-yy")