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
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
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")
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.