I have several sheets with data, all starting with "input" in the sheetname and all having a date column in column A. I want to create a userform that allows the user to insert a date in a textbox. This date will refer to the date column in the specified sheets. When the user has clicked "Okay", the macro should delete all rows in the sheets from Now() till the specified date. In other words it starts from the bottom and deletes upwards. The rows are not initially sorted according to date. This is what I have so far:
Sub Rens_date()
Dim lRow As Long
Dim lcol
Dim iCntr As Long
Dim wb As Workbook
Set wb = ThisWorkbook.Worksheets
With wb
lRow = wb.Range("A" & Rows.Count).End(xlUp).Row
lcol = wb.Range("A" & Columns.Count).End(xlUp).Column
Set deleterange = .Range(Rens_inputbox.Value, .Cells(lRow, lcol))
End With
For Each Row In deleterange
If wb.Range("A").Cells = Me.Rens_inputbox.Value Then _
deleterange.Delete
End If
Next
End Sub
Code is not working :/
Place this code on your Okay button and this should work. It will iterate over the entire first column of all sheets which has a name that starts with "input_" looking for date between the current date and the date you typed in the textbox.
Private Sub CommandButton1_Click()
Dim actCell As Range
Dim lastDate As Date
Dim startDate As Date
Dim currentCellDate As Date
Dim ws As Worksheet
lastDate = CDate(TextBox1.Value)
startDate = Date
For Each ws In ActiveWorkbook.Worksheets
If LCase(ws.Name) Like "input_*" Then
For Each actCell In ws.ListObjects(1).DataBodyRange.Columns(1).Cells
currentCellDate = CDate(actCell.Value)
If currentCellDate > startDate And currentCellDate < lastDate Then
actCell.EntireRow.Delete
End If
Next
End If
Next
End Sub
Related
i have tried many sites and am really struggling as i cant seem to understand the VBA code
tab1 = data from C8:Rx? ... the data will continously grow so table will get bigger all the time
Column C in tab1 contains dates 21/05/2021
I want to be able to have 2 prompt boxes where i enter a date from and date to 21/05/2021 - 22/05/2021
when i action the macro it will take only the data from the table in tab1 in between these dates
and paste them in tab2 at cell ref c8 (the start of the table)
Option Explicit
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorkbook(strStart, strEnd)
End Sub
'This subroutine creates the new workbook based on input from the prompts
Public Sub CreateSubsetWorkbook(StartDate As String, EndDate As String)
Dim wbkOutput As Workbook
Dim wksOutput As Worksheet, wks As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
lngDateCol = 3 '<~ we know dates are in column C
Set wbkOutput = Workbooks.Add
'Loop through each worksheet
For Each wks In ThisWorkbook.Worksheets
With wks
'Create a new worksheet in the output workbook
Set wksOutput = wbkOutput.Sheets.Add
wksOutput.Name = wks.Name
'Create a destination range on the new worksheet that we
'will copy our filtered data to
Set rngTarget = wksOutput.Cells(1, 1)
'Identify the data range on this sheet for the autofilter step
'by finding the last row and the last column
lngLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lngLastCol = .Cells.Find(What:="*", LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set rngFull = .Range(.Cells(1, 1), .Cells(lngLastRow, lngLastCol))
'Apply a filter to the full range to get only rows that
'are in between the input dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'Copy only the visible cells and paste to the
'new worksheet in our output workbook
Set rngResult = rngFull.SpecialCells(xlCellTypeVisible)
rngResult.copy Destination:=rngTarget
End With
'Clear the autofilter safely
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
Next wks
'Let the user know our macro has finished!
MsgBox "Data transferred!"
End Sub
What this solution does:
Assumes your dates are in Column A of your worksheet.
Can be used to replace the CreateSubsetWorkbook sub you have.
You can still use the PromptUserForInputDates and then call this sub instead of CreateSubsetWorkbook.
Public Sub FillOutputRange(ByVal StartDate As Date, ByVal EndDate As Date)
Dim SourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim TargetCell As Range
Dim LastRow As Long
Dim StartRow As Long
Dim EndRow As Long
Dim RowLoopCounter As Long
Dim EndColumn As Long
Dim OutputDataArray As Variant
With ThisWorkbook
Set SourceSheet = .Sheets("Sheet1") 'Change this to the name of your source sheet
Set DestinationSheet = .Sheets("Sheet2") 'Change this to the name of your destination sheet
End With
With SourceSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each TargetCell In .Range("A1:A" & LastRow)
If TargetCell.Value = StartDate Then
StartRow = TargetCell.Row
Exit For
End If
Next TargetCell
If StartRow = 0 Then MsgBox "Start Date was not found", vbOKOnly, "No Start Date": Exit Sub
For RowLoopCounter = LastRow To StartRow Step -1
If .Range("C" & RowLoopCounter).Value = EndDate Then
EndRow = RowLoopCounter
Exit For
End If
Next RowLoopCounter
If EndRow = 0 Then MsgBox "End Date was not found", vbOKOnly, "No End Date": Exit Sub
EndColumn = .Cells(EndRow, .Columns.Count).End(xlToLeft).Column
OutputDataArray = .Range(.Cells(StartRow, "A"), .Cells(EndRow, EndColumn)).Value
End With
With DestinationSheet
.Range("C8").Resize(UBound(OutputDataArray, 1), UBound(OutputDataArray, 2)).Value = OutputDataArray
End With
End Sub
How does it work?
The flow of this sub can be described as:
First we set variables to use as reference to our SourceSheet and DestinationSheet - Be sure to change these to the correct worksheet names for your workbook.
Then with the SourceSheet we find the LastRow - see "Better way to find last row"
Then we use a For Each Next Statement to loop through each cell in the Range("A1:A" & LastRow") - If LastRow is say, 10 then this would be equivalent to Range("A1:A10")
With each iteration of the loop we are checking if the cell's value matches our StartDate argument passed from the PromptUserForInputDates Sub.
Once we have our first match, we assign the Row of that cell to the StartRow variable and the loop is exited and the code continues.
The next loop is a For Next Statement which works with slightly different syntax. I've used this to demonstrate using the different statement. We loop backwards from the end of the range, back to the StartRow so this way the EndRow will be established from the last occurrence of the EndDate in your range.
Now that we have the StartRow and EndRow we know which rows the target data are in between (inclusive).
EndColumn is found based on the last column with data in the EndRow - you can find this based on any row, I just chose to find it with the end row.
Using the 3 variables, StartRow, EndRow, and EndColumn we can build our OutputDataArray by assigning the value of the target range to the array variable. This automatically builds a two dimensional array with all the data in it.
Finally, with our DestinationSheet we now write the array to a range in the sheet. I've hard coded this to start at Range("C8") per your question.
The Range.Resize Property is used to change the Range size to match the Array size, this way the data from the Array writes directly into the sheet.
This Chip Pearson article is great for learning about Arrays.
Note: I've added If...Then statements after each loop to catch errors that will appear if either of the variables StartRow and/or EndRow are not assigned (meaning they retain their default value of 0). This handles the error by throwing a messagebox to the user advising whichever date hasn't been found.
Demonstration
Based on the following dates being used:
StartDate = 3/6/2021
EndDate = 6/6/2021
Sample Source data:
Outcome of running sub:
my code error
Error says application defined or object defined error
Sorry for all the trouble #samuel
Option Explicit
'This subroutine prompts the user to select dates
Public Sub PromptUserForInputDates()
Dim strStart As String, strEnd As String, strPromptMessage As String
'Prompt the user to input the start date
strStart = InputBox("Please enter the start date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = InputBox("Please enter the end date")
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call FillOutputRange(strStart, strEnd)
End Sub
Public Sub FillOutputRange(ByVal StartDate As Date, ByVal EndDate As Date)
Dim SourceSheet As Worksheet
Dim DestinationSheet As Worksheet
Dim TargetCell As Range
Dim LastRow As Long
Dim StartRow As Long
Dim EndRow As Long
Dim RowLoopCounter As Long
Dim EndColumn As Long
Dim OutputDataArray As Variant
With ThisWorkbook
Set SourceSheet = .Sheets("Branches consolidated Master (4") 'Change this to the name of your source sheet
Set DestinationSheet = .Sheets("Date Extract (5)") 'Change this to the name of your destination sheet
End With
With SourceSheet
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
For Each TargetCell In .Range("C8:C" & LastRow)
If TargetCell.Value = StartDate Then
StartRow = TargetCell.Row
Exit For
End If
Next TargetCell
For RowLoopCounter = LastRow To StartRow Step -1
If Range("C" & RowLoopCounter).Value = EndDate Then
EndRow = RowLoopCounter
Exit For
End If
Next RowLoopCounter
EndColumn = .Cells(EndRow, .Columns.Count).End(xlToLeft).Column
OutputDataArray = .Range(.Cells(StartRow, "A"), .Cells(EndRow, EndColumn)).Value
End With
With DestinationSheet
.Range("C8").Resize(UBound(OutputDataArray, 1), UBound(OutputDataArray, 2)).Value = OutputDataArray
End With
End Sub
I'm having the following columns in Excel: Document Date (all cells have values) & Initial Disposition Date (there're blanks within the column).
Each Document Date cell corresponds to an Initial Disposition Date cell.
For any blank Initial Disposition Date cells, I'd like to set them to be 7 days from the corresponding Document Date. (Strictly blank cells)
Ex: Document Date = 10/01/2018. Desired Initial Disposition Date = 10/08/2018.
Is there a code to execute such action? (I have approximately 55,000 rows and 51 columns by the way).
Thank you very much! Any suggestions or ideas are highly appreciated!
Looping through a range is a little quicker in this case. I am assuming your data is on Sheet1, your Document Date is on Column A and your Initial Deposition is on Column B.
Last, you need to determine if you want that 7 days to be inclusive of weekends or not. I left you a solution for both. You will need to remove one of the action statements (in middle of loop)
Option Explicit
Sub BetterCallSaul()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LRow As Long, iRange As Range, iCell As Range
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set iRange = ws.Range("B2:B" & LRow)
Application.ScreenUpdating = False
For Each iCell In iRange
If iCell = "" Then
iCell = iCell.Offset(, -1) + 7 'Includes Weekends
iCell = WorksheetFunction.WorkDay(iCell.Offset(, -1), 7) 'Excludes Weekends
End If
Next iCell
Application.ScreenUpdating = True
End Sub
If your Document Date is on Column A and you Initial Disposition Date in Column B, then the following would achieve your desired results:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To Lastrow
'loop from row 2 to the last row with data
If ws.Cells(i, "B").Value = "" Then
'if there is no value in Column B then
ws.Cells(i, "B").Value = ws.Cells(i, "A").Value + 7
'add seven days to the date from Column A
End If
Next i
End Sub
A formula on all blanks would avoid the delays looping through the worksheet column(s).
Sub ddPlus7()
Dim dd As Long, didd As Long
With Worksheets("sheet1")
'no error control on the next two lines so those header labels better be there
dd = Application.Match("Document Date", .Rows(1), 0)
didd = Application.Match("Desired Initial Disposition Date", .Rows(1), 0)
On Error Resume Next
With Intersect(.Columns(dd).SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow, _
.Columns(didd).SpecialCells(xlCellTypeBlanks).EntireRow, _
.Columns(didd))
.FormulaR1C1 = "=rc[" & dd - didd & "]+7"
End With
On Error GoTo 0
End With
End Sub
I am pulling data from various cells on Sheet1 in Excel and copying the values to specific cells on a row in Sheet2 every specified period of time. I almost have my project completed but am unable to copy concatenated data in the same manner. How would I incorporate the following excel statement into my code for the data to be copied on sheet2 from sheet1? The output should go into cell AB on Sheet2.
Not to confuse the issue but the reason the code is done in this manner is so that data can be entered on sheet 1 which will be the active sheet on the screen at all times but data will be periodically be saved to sheet2.
Excel Statement i need to incorporate and output to Cell "AB" on sheet2:
=CONCATENATE(Sheet1!I9,", ",Sheet1!I10,", ",Sheet1!I11,", ",Sheet1!I12)
Current Code:
Option Explicit
Public dTime As Date
Sub ValueStore()
Dim dTime As Date
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Set ws2 = ActiveWorkbook.Worksheets("Sheet2")
Dim lRow As Long
lRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
With ws2
Range("X1:X" & lRow).Offset(1).Value = ws1.Range("F15").Value
Range("Y1:Y" & lRow).Offset(1).Value = ws1.Range("F14").Value
Range("Z1:Z" & lRow).Offset(1).Value = ws1.Range("F17").Value
Range("AA1:AA" & lRow).Offset(1).Value = ws1.Range("F16").Value
End With
StartTimer1
End Sub
Sub StartTimer1()
dTime = Now + TimeValue("00:00:05")
Application.OnTime dTime, "ValueStore", Schedule:=True
End Sub
Sub StopTimer1()
On Error Resume Next
Application.OnTime dTime, "ValueStore", Schedule:=False
End Sub
Try this:
Sub ValueStore()
Dim dTime As Date, rw As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Set ws2 = ActiveWorkbook.Worksheets("Sheet2")
'find the next empty row on ws2
Set rw = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow
With rw
' note the .Range() here is *relative* to rw
.Range("A1").Value = Now '<< ensure a value is placed in colA....
.Range("X1").Value = ws1.Range("F15").Value
.Range("Y1").Value = ws1.Range("F14").Value
.Range("Z1").Value = ws1.Range("F17").Value
.Range("AA1").Value = ws1.Range("F16").Value
'method1 (contiguous vertical range)
.Range("AB1").Value = Join(Application.Transpose(ws1.Range("I9:I12").Value), ", ")
'method2 (join individual cells)
.Range("AB1").Value = Join(Array(ws1.Range("I9"), ws1.Range("I10"), _
ws1.Range("I11"), ws1.Range("I12")), ", ")
End With
StartTimer1
End Sub
favorite
My current macro pulls in multiple workbooks bringing in roughly 100 worksheets. The macro then filters and pulls in the data from 10 or 11 specific worksheets to create a new sheet with the data I need. Each of the 100 sheets has fairly unique names from "DataFX GL Data" to "SAP_ALL_175031".
There is one file I am having a hard time selecting. It is labeled with a date. Each month a new sheet is added with a day and month ("30 November" for example). I am new to vba and am not certain where to begin so I only have an example of another sheet that I am selecting. How can I select the worksheet labeled with the most recent date?
Dim Deleterow As Long, EndRow As Long
Dim lRow As Variant
Dim rngRow As Range
Dim rngSelection As Range
Set rngSelection = Range("A1").CurrentRegion
For Each ws In ActiveWorkbook.Worksheets
With ws
If Left(ws.Name, 7) = "Sheet 1" Then
EndRow = LastRow(ws)
For Deleterow = EndRow To 2 Step -1
If .Cells(Deleterow, 9) = .Cells(Deleterow, 12) Then
.Rows(Deleterow).EntireRow.Delete
End If
Next Deleterow
End If
You can use the EOMonth WorksheetFunction inside the VBA code to determine the last day of the previous month:
Dim lastMonth As Date
lastMonth = WorksheetFunction.EoMonth(Date, -1)
Debug.Print lastMonth
Debug.Print Format(lastMonth, "dd mmmm")
Results:
12/31/2017
31 December
Then
If ws.Name = Format(lastMonth, "dd mmmm") Then
To get the name of the worksheet with the latest date, given the constraint that all of the dates are within the same year, you can do something like the following:
Option Explicit
Sub LatestWorksheet()
Dim WB As Workbook, WS As Worksheet
Dim wsName As String
Set WB = ThisWorkbook
For Each WS In WB.Worksheets
If IsDate(WS.Name) Then
If wsName = "" Then
wsName = WS.Name
ElseIf DateValue(WS.Name & " 2012") > DateValue(wsName & " 2012") Then _
wsName = WS.Name
End If
End If
Next WS
Debug.Print wsName
End Sub
Note that I fixed the year to 2012 in order to allow for 29 Feb. Otherwise it would alter the proper order. Given the date/string, VBA would assume the current year. If the file year were a leap year, and the current year was not, 29 Feb would get converted in an undesired manner by the DateValue function.
I have a multiple worksheets within a workbook that have every day spelled out in column A (A2:A367). Upon opening the workbook, I am trying to hide all rows not pertaining to the current month. I'm not sure if there is a way to automatically pull the current date from Excel and have the rows adjusted. I am currently writing code to activate every worksheet within the workbook and go thru each row and hide rows from other months. Is there a more efficient way to loop and hide rows based on month?
"Regionwide" is first worksheet of 8.
Sub Macro3()
Sheets("Regionwide").Select
Range("A2").Select
Dim cell As Range
Const Month As String = "2"
'Dim Month As String
'Month = MonthName(2)
Dim LR As Long, I As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LR
If Left(Range("A" & I).Value, 2) <> Month Then
cell.EntireRow.Hidden = True
' Range("AC" & I).Value = "Reinsurance"
'Else
' cell.EntireRow.Hidden = True
End If
Next I
End Sub
You can get today's month with:
Dim intMonth As Integer
intMonth = Month(Now())
You can also loop through all the sheets with something like:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
LR = ws.Range("A" & Rows.Count).End(xlUp).Row
...
Next
You don't have to select sheets or cells to perform actions on it. Refering to it through ActiveWorkbook.Sheets(index).Range(range) can speed up your code.