At least post your VBA code (nothing special needed to do that, see here:
How to Post Your VBA Code), and a screen print of your data.
Here is the code, sorry I had no access to the sheet.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
If Target.Row > 1 And Target.Column = 10 Then
If Target.Formula = "" Then
Target.Formula = Target.Offset(-1, 0).Formula
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngIntersect As Range
Dim tbl As ListObject
Set tbl = Me.ListObjects(1) ' Assuming your table is the first ListObject on the sheet
Set rngIntersect = Intersect(Target, tbl.ListColumns("Date").DataBodyRange)
' Check if the changed cell is within the table
If Not rngIntersect Is Nothing Then
' Disable events to prevent recursive triggering
Application.EnableEvents = False
Application.ScreenUpdating = False
' Set up and apply search characteristic to the 1st selected cell in the Date column
Dim origFnt As String, tmpFnt As String
With rngIntersect.Cells(1)
origFnt = .Font.Name
tmpFnt = "Comic Sans MS"
.Font.Name = tmpFnt
End With
' Sort the table based on the "Date" column in ascending order
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add Key:=tbl.ListColumns("Date").DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending
tbl.Sort.Apply
' Find search characteristic applied to Target cell
With Application.FindFormat
.Clear
.Font.Name = tmpFnt
End With
Dim origCell As Range
With tbl.ListColumns("Date").DataBodyRange
Set origCell = .Find(What:="*", SearchFormat:=True)
.Font.Name = origFnt ' Apply to whole column or table might get confused
End With
Application.FindFormat.Clear
' Activate original target cell, if multiple cells 1st cell in date column in target range
'If ActiveSheet.Shapes("CommandButton1").OLEFormat.Object.Object Is Me.CommandButton1 Then
' Code to execute when CommandButton1 is clicked
' MsgBox "CommandButton1 was clicked!"
'Else
' Code to execute when CommandButton1 is not clicked
' origCell.Select
'End If
' If runOrigCellSelect <> 1 Then
origCell.Select
' End If
' Re-enable events
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Private Sub CommandButton1_Click()
' Sub ModifyDateWithNumericValue()
Dim userMonth As Integer
Dim userDay As Integer
Dim modifiedDate As Date
Dim userInput As Variant
Dim cellChangeCount As Long
Dim wsName As String
Dim targetCell As Range
' Set the target cell (N3 in this case) for the active sheet
Set targetCell = ActiveSheet.Range("N3")
' Get the value from the target cell
wsName = targetCell.Value
' Check if the worksheet with the specified name exists
On Error Resume Next
' Initialize the cell change count
cellChangeCount = 0
' Prompt the user for the month using a MsgBox
userInput = InputBox("Enter the month (1-12):")
' Check if the user provided a valid numeric value for the month
If IsNumeric(userInput) Then
userMonth = CInt(userInput)
' Check if the month is within the valid range (1-12)
If userMonth >= 1 And userMonth <= 12 Then
' Declare a cell variable to keep track of the current cell
Dim currentCell As Range
Set currentCell = ThisWorkbook.Sheets(wsName).Range("M20") ' Change the sheet and starting cell as needed
' Initialize the userDay variable
userDay = CInt(ThisWorkbook.Sheets(wsName).Range("L20").Value)
' Loop until the current cell is empty
Do While currentCell.Value <> ""
' Create a new date using the provided month and day
modifiedDate = DateSerial(Year(Date), userMonth, userDay)
' Copy the value of the modified date to the current cell
currentCell.Value = modifiedDate
' Increment the cell change count
cellChangeCount = cellChangeCount + 1
' Move to the next cell (one cell down)
Set currentCell = currentCell.Offset(1, 0)
' Offset the userDay value as well (one cell down)
userDay = CInt(currentCell.Offset(0, -1).Value)
Loop
Dim sourceRange As Range
Dim destRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim ws As Worksheet
Dim targetRow As ListRow
Dim targetTable As ListObject
Dim sourceRow As Range
Dim runOrigCellSelect As Long
' Set the source worksheet
Set ws = ThisWorkbook.Sheets(wsName) ' Change "Sheet1" to your source sheet name
' Define the source range (adjust the starting cell as needed)
Set sourceRange = ws.Range("M20:V40") ' Change "A1" to the starting cell of your source data
' Set the target table where you want to paste the data
Set targetTable = ws.ListObjects(wsName) ' Change "Table1" to your table name
' Find the last row and last column with data in the source range
lastRow = ws.Cells(ws.Rows.Count, sourceRange.Column).End(xlUp).Row
lastCol = ws.Cells(sourceRange.Row, ws.Columns.Count).End(xlToLeft).Column
' Loop through each row in the source range
For Each sourceRow In sourceRange.Rows
' Check if the row has data in it
If WorksheetFunction.CountA(sourceRow) > 0 Then
runOrigCellSelect = 1
' Set the last cell in the source row
Set lastCell = sourceRow.Cells(1, lastCol)
' Add a new row to the target table
Set targetRow = targetTable.ListRows.Add
' Copy the source row and paste it into the target row
sourceRow.Copy
targetRow.Range.Cells(1, 1).PasteSpecial xlPasteFormulas ' You can change the paste type as needed
' Clear the clipboard (optional)
Application.CutCopyMode = False
End If
Next sourceRow
' Clean up
Set sourceRange = Nothing
Set targetTable = Nothing
Set targetRow = Nothing
Set ws = Nothing
runOrigCellSelect = 0
Else
MsgBox "Invalid month. Please enter a month between 1 and 12."
End If
Else
MsgBox "Invalid input. Please enter a numeric value for the month."
End If
End Sub
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim userMonth As Integer
Dim userDay As Integer
Dim modifiedDate As Date
Dim cellChangeCount As Long
Dim wsName As String
Dim currentCell As Range
Dim dayCell As Range
Dim sourceRange As Range
Dim destRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim targetRow As ListRow
Dim targetTable As ListObject
Dim sourceRow As Range
runOrigCellSelect = 1
' Set the target worksheet (specified in cell N3 of the active sheet)
wsName = ActiveSheet.Range("N3").Value
Set ws = ThisWorkbook.Sheets(wsName)
' Initialize the cell change count
cellChangeCount = 0
' Prompt the user for the month using a MsgBox
' userInput =
strIn = UCase$(InputBox("Bi Weekly Continue Y/N"))
' Check if the month is within the valid range (y/N)
If strIn = "Y" Then
' Loop through the cells in column S and corresponding cells in column R
' Loop until the current cell is empty
Do While currentCell.Value <> ""
For Each currentCell In ws.Range("M45:M" & ws.Cells(ws.Rows.Count, "M").End(xlUp).Row)
Set dayCell = currentCell.Offset(0, -1) ' Corresponding cell in column R
userDay = Day(currentCell.Offset(0, -1)) ' Extract the day from the new date
' Calculate the starting date based on user-provided month and the new day
modifiedDate = dayCell
' Update the date every two weeks in column S
modifiedDate = modifiedDate + 14 ' Add 14 days (two weeks)
currentCell.Value = modifiedDate
' Update the day in column R with the new day
dayCell.Value = currentCell.Value
cellChangeCount = cellChangeCount + 1
'Next currentCell
' Set the source worksheet
Set ws = ThisWorkbook.Sheets(wsName) ' Change "Sheet1" to your source sheet name
' Define the source range (adjust the starting cell as needed)
Set sourceRange = ws.Range("M45:U60") ' Change "A1" to the starting cell of your source data
' Set the target table where you want to paste the data
Set targetTable = ws.ListObjects(wsName) ' Change "Table1" to your table name
' Find the last row and last column with data in the source range
lastRow = ws.Cells(ws.Rows.Count, sourceRange.Column).End(xlUp).Row
lastCol = ws.Cells(sourceRange.Row, ws.Columns.Count).End(xlToLeft).Column
' Loop through each row in the source range
For Each sourceRow In sourceRange.Rows
' Check if the row has data in it
If WorksheetFunction.CountA(sourceRow) > 0 Then
' Set the last cell in the source row
Set lastCell = sourceRow.Cells(1, lastCol)
' Add a new row to the target table
Set targetRow = targetTable.ListRows.Add
' Copy the source row and paste it into the target row
sourceRow.Copy
targetRow.Range.Cells(1, 1).PasteSpecial xlPasteFormulas ' You can change the paste type as needed
' Clear the clipboard (optional)
Application.CutCopyMode = False
End If
Next sourceRow
' Clean up
Set sourceRange = Nothing
Set targetTable = Nothing
Set targetRow = Nothing
Set ws = Nothing
End If
End Sub
