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

Question

I am trying to figure out a tidy way to write the following scenario.

Worksheet A Has a list that, from project to project will vary in the number of rows in it.

Example of information in Worksheet A. Data to be used in Calendar Month column.

Worksheet B Tracking sheet that is using the list from Worksheet A, to populate the titles of columns going across the sheet.

I want the script to use the value in each of the rows (3 times each before moving to the next row) from Worksheet A, across the top of worksheet B to create the titles for a table.

---

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

I believe the following code will do what you expect, it will loop through Sheet A, format the date accordingly and then write your headers in Sheet B as illustrated in the image starting in the Column A in Sheet 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

Just an idea how to do it more efficient. You might want to improve the formatting part, just tried to illustrate how it could be done.

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

Note that I used WsSource.Cells(iRow, "A").Text to get the date of the source sheet exactly in the format as it is formatted there. If you want to change that you would need something like Format(WsSource.Cells(iRow, "A").Value, "mmm-yy")