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.
Related
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 attempting to have VBA scan cells in column DQ for a specific text value of "AcuteTransfer" and then to cut the row containing that cell and past into the first available row of a new sheet.
This value would be listed multiple times and each listing would need to be cut and pasted over
sheet containing the cell is "adds&reactivates" and sheet where row would be pasted to is "ChangeS".
Any recommendations would be amazing.
So far I have
Sub ohgodwhathaveIdone()
Dim endRow As Long
Dim Match1() As Variant
Dim ws As Worksheet
Set ws = Worksheets("adds&reactivates")
ICount = 0
endRow = Sheets("adds&reactivates").Range("DQ999999").End(xlUp).Row
Match1 = Sheet1.Range("DQ2:DQ" & endRow)
For I = LBound(Match1) To UBound(Match1)
If Match1(I, 1) = "AcuteTransfer" Then
Sheets("adds&reactivates").Cells(I, "A").EntireRow.Copy Destination:=Sheets("changes").Range("A" & Sheets("Changes").Rows.Count).End(xlUp).Offset(1)
Else
End If
Next I
End Sub
Try this out - this is assuming both pages have headers on row 1.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("adds&reactivates")
Set sht2 = ThisWorkbook.Worksheets("ChangeS")
For i = 2 To sht1.Cells(sht1.Rows.Count, "DQ").End(xlUp).Row
If sht1.Range("DQ" & i).Value = "AcuteTransfer" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "DQ").End(xlUp).Row + 1)
End If
Next i
End Sub
Hello stackoverflow community,
I must confess I primarily code within MS Access and have very limited experience of MS Excel VBA.
My current objective is this, I have an "Expense Report" being sent to me with deductions, this report has many columns with different account names that may be populated or may be null.
My first step will be to start on the first record (Row 14; Column A-K contains personal info regarding the deduction) then skip to the first deduction account (deduction accounts start at column L and span to column DG) checking if each cell is null, if it is then keep moving right,If there is a value present, I need to copy it into an external workbook "Payroll Template" starting at row 2 (Column J for the deduction itself), as well as copy some personal info from the original row in the "Expense Report" related to that deduction (currRow: Column C,E,F from "Expense Report" to "Payroll Template" Columns B,C,D).
Then move to the right until the next cell contains a value, and repeat this process on a new row in the "Payroll Template". Once the last column (DG) has been executed I want to move to the next row (row 15) and start the process again all the way until the "LastRow" in my "Used Range".
I greatly appreciate any feedback, explanations, or links that may point me towards my goal. Thank you in advance for taking the time to read though this!
Current state of code:
`< Sub LoadIntoPayrollTemplate()
Dim rng As Range
Dim currRow As Integer
Dim UsedRng As Range
Dim LastRow As Long
Set UsedRng = ActiveSheet.UsedRange
currRow = 14
Set wb = ActiveWorkbook '"Expense Report"
Set wb2 = MyFilepath '"Payroll Template"
'Copied from another procedure, trying to use as reference
LastRow = rng(rng.Cells.Count).Row
Range("A14").Select
Do Until ActiveCell.Row = LastRow + 1
If (ActiveCell.Value) <> prev Then
currRow = currRow + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
With Worksheets("Collections")
lstRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range(.Cells(14, 12), Cells(lstRow, 111))
End With
End Sub>`
The following code may do what you are after:
Sub LoadIntoPayrollTemplate()
Dim currRowIn As Long
Dim currColIn As Long
Dim currRowOut As Long
Dim wb As Workbook
Dim wb2 As Workbook
Set wb = ActiveWorkbook '"Expense Report"
Set wb2 = Workbooks.Open(Filename:=MyFilepath & "\" & "Payroll Template.xlsx")
'or perhaps
'Set wb2 = Workbooks.Open(Filename:=wb.path & "\" & "Payroll Template.xlsx")
With wb.ActiveSheet
currRowOut = 1
For currRowIn = 14 To .UsedRange.Row + .UsedRange.Rows.Count - 1
For currColIn = 12 To 111
If Not IsEmpty(.Cells(currRowIn, currColIn)) Then
currRowOut = currRowOut + 1
'I'm not sure which worksheet you want to write the output to
'so I have just written it to the first one in Payroll Template
wb2.Worksheets(1).Cells(currRowOut, "J").Value = .Cells(currRowIn, currColIn).Value
wb2.Worksheets(1).Cells(currRowOut, "B").Value = .Cells(currRowIn, "C").Value
wb2.Worksheets(1).Cells(currRowOut, "C").Value = .Cells(currRowIn, "E").Value
wb2.Worksheets(1).Cells(currRowOut, "D").Value = .Cells(currRowIn, "F").Value
End If
Next
Next
End With
'Save updated Payroll Template
wb2.Save
End Sub
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
I have the data of the following type in excel:
Year|Trade Flow|Partner|Commodity Code|Commodity|Qty Unit|Qty|Netweight (kg)|Trade Value (US$)
In the year column it ranges from 1990 to 2014. I need to develop a macro code such that it can filter the values based on year individually and then paste it in different sheets of the same excel file.
Any help in this regard,. would be great.
Thanks.
Loop through the rows. Each time you hit a new year, insert a sheet for that year and copy the rows to it.
This assumes your data is on sheet1 and you don't have sheets named 1990, 1991, 1992, etc.
This also assumes that your data is sorted by ColumnA(Year).
Private Sub CommandButton1_Click()
Dim ws As Excel.Worksheet
Dim strValue As String
Set ws = ActiveWorkbook.Sheets("Sheet1")
Dim jRow As Long
Dim lRow As Long
lRow = 1
jRow = 1
ws.Activate
'Loop through and copy the records to the new sheet.
Do While lRow <= ws.UsedRange.Rows.count
'If this is a new year, create a sheet for it.
If ws.Range("A" & lRow).Value <> strValue Then
strValue = ws.Range("A" & lRow).Value
Worksheets.Add(After:=Worksheets(Worksheets.count)).name = strValue
jRow = 1
End If
ws.Rows(lRow).Copy Destination:=Worksheets(strValue).Range("A" & jRow)
jRow = jRow + 1
lRow = lRow + 1
Loop
End Sub