Lock Entire Row Based On Date - vba

I have Cell A1 with Month mentioned. I am trying to compare date in A2:last cell and wherever date > A1, I want the row to be unlocked, otherwise locked. The below code doesn't work"
Sub Lockrow()
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Integer
Set DestSh = Sheets("Consultant & Volunteer")
With DestSh
'finds the last row with data on A column
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
'parse all rows
For i = 6 To lastrow
'if your conditions are met
If Month(.Cells(i, 26)) > Month(.Cells(1, 1)) Then
.Range("A" & i).EntireRow.Cells.Locked = True 'lock the row
End If
Next i
End With
End Sub

This can be done simply with below, but you have to be careful that Year doesn't change... Also the lastrow should be on Column Z.
Also, if the worksheet isn't Protected, there is no effect.
Option Explicit
Sub Lockrow()
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Long ' Integer
Set DestSh = Sheets("Consultant & Volunteer")
With DestSh
'finds the last row with data on A column
lastrow = .Range("Z" & .Rows.Count).End(xlUp).Row ' <-- EDIT
'parse all rows
For i = 6 To lastrow
'if your conditions are met
.Rows(i).Locked = Not (Month(.Cells(i, "Z")) > Month(.Range("A1")))
' If Month(.Cells(i, 26)) > Month(.Cells(1, 1)) Then
' .Range("A" & i).EntireRow.Cells.Locked = True 'lock the row
' End If
Next i
.Protect UserInterfaceOnly:=True
End With
Set DestSh = Nothing
End Sub

Alternative to loop.
Dim r As Range, DestSh As Worksheet, lastrow As Long
Set DestSh = Sheets("Consultant & Volunteer")
With DestSh
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set r = .Range("A1:A" & lastrow)
r.EntireRow.Locked = False
r.AutoFilter 1, ">" & .Range("A1").Value2
r.SpecialCells(xlCellTypeVisible).EntireRow.Locked = True
.AutoFilterMode = False
.Protect UserInterfaceOnly:=True
End With

Related

Copy Range into Specific Row/Cell and avoid overwriting the data

Fairly new to VBA Excel. I want to copy and paste a specific cell[B11 and so on) into a specific cell [E9 and so on] on my target sheet when conditions are met (when C column is equal to No). So far I was able to copy and paste the data on my target sheet. Having trouble when I run the command again. I don't want to overwrite my previous data. How can this be done? `
Private Sub CommandButton1_Click()
Dim RowGCnt As Long, CShtRow As Long
Dim LastRow As Long
Dim CellG As Range
'paste the first result to the 9th row
CShtRow = 9
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If Range("C" & RowGCnt).Value = "No" Then
MsgBox (CShtRow)
'Review Criteria
Worksheets("SHEET1").Range("B" & RowGCnt).Copy
Worksheets("REPORT").Range("E" & CShtRow).PasteSpecial xlPasteValues
CShtRow = CShtRow + 1
End If
Next RowGCnt
Application.CutCopyMode = False
End Sub
Untested:
Private Sub CommandButton1_Click()
Dim shtSrc As Worksheet '<< source sheet
Dim RowGCnt As Long
Dim LastRow As Long
Dim cDest As Range '<< copy destination
Set shtSrc = Worksheets("SHEET1")
'paste the first result to the first open row
With Worksheets("REPORT")
Set cDest = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0) '<<EDIT
If cDest.Row < 9 Then Set cDest = .Range("E9")
End With
LastRow = shtSrc.Range("A" & shtSrc.Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If shtSrc.Range("C" & RowGCnt).Value = "No" Then
cDest.Value = shtSrc.Range("B" & RowGCnt).Value
Set cDest = cDest.Offset(1, 0)
End If
Next RowGCnt
End Sub
Using Tim Williams code. I got a workaround
Private Sub CommandButton1_Click()
Dim shtSrc As Worksheet '<< source sheet
Dim RowGCnt As Long
Dim LastRow As Long
Dim cDest As Range '<< copy destination
Dim vLastRow As Integer
Set shtSrc = Worksheets("SHEET1")
'paste the first result to the first open row
With Worksheets("REPORT")
Set cDest = .Cells(.Rows.Count, "E").End(xlUp)
If cDest.Row < 9 Then
Set cDest = .Range("E9")
Else
vLastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
Set cDest = .Cells(vLastRow + 1, 5)
End If
End With
LastRow = shtSrc.Range("A" & shtSrc.Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If shtSrc.Range("C" & RowGCnt).Value = "No" Then
cDest.Value = shtSrc.Range("B" & RowGCnt).Value
Set cDest = cDest.Offset(1, 0)
End If
Next RowGCnt
End Sub

VBA Copy entire row if cell matches a value for entire sheet

I'm trying to have an update button where it checks the cells in column H for values "not started" or "closed" and cut/paste these cells to the corresponding sheet. The code I currently have doesn't treat every cell and only copies one row to each sheet.
Screenshot:
Private Sub CommandButton1_Click()
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim lastRow As Long
Dim Cell As Range
'Set variables
Set sht1 = Sheets("To DO")
Set sht2 = Sheets("Ongoing")
Set sht3 = Sheets("Done")
'Select Entire Row
Selection.EntireRow.Select
'Move row to destination sheet & Delete source row
lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
With sht2
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
If Cell.Value = "Not started" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=sht1.Rows(lastRow1 + 1)
.Rows(Cell.Row).Delete
ElseIf Cell.Value = "Closed" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=sht3.Rows(lastRow3 + 1)
.Rows(Cell.Row).Delete
End If
Next Cell
End With
MsgBox "Update Done!"
End Sub
Normally when you need to delete the rows based on a criteria, you should use a counter variable and loop through the cells in the reverse order.
But if you are looping through cells using range/cell objects, you should not delete the row just after copying it to another sheet. Instead, you should declare a range variable and store the address of all the cells which qualify for the row delete criteria and delete them all at once in the end.
In this scenario, the Autofilter is an ideal candidate to use.
Please try the tweaked version of your original code.
Private Sub CommandButton1_Click()
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
Dim Cell As Range
Dim RngToDelete As Range
Application.ScreenUpdating = False
'Set variables
Set sht1 = Sheets("To DO")
Set sht2 = Sheets("Ongoing")
Set sht3 = Sheets("Done")
'Select Entire Row
'Selection.EntireRow.Select
'Move row to destination sheet & Delete source row
lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
lastRow2 = sht2.Range("A" & sht2.Rows.Count).End(xlUp).Row
lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
With sht2
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("H2:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
If Cell.Value = "Not started" Then
If RngToDelete Is Nothing Then
Set RngToDelete = Cell
Else
Set RngToDelete = Union(RngToDelete, Cell)
End If
lastRow1 = sht1.Range("A" & sht1.Rows.Count).End(xlUp).Row
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=sht1.Rows(lastRow1 + 1)
'.Rows(Cell.Row).Delete
ElseIf Cell.Value = "Closed" Then
If RngToDelete Is Nothing Then
Set RngToDelete = Cell
Else
Set RngToDelete = Union(RngToDelete, Cell)
End If
lastRow3 = sht3.Range("A" & sht3.Rows.Count).End(xlUp).Row
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=sht3.Rows(lastRow3 + 1)
'.Rows(Cell.Row).Delete
End If
Next Cell
End With
If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete
Application.CutCopyMode = 0
Application.ScreenUpdating = True
MsgBox "Update Done!"
End Sub
Edit: as per comment corrected sht to sht2
when deleting items from a Collection (like rows in a Range is) you should proceed from bottom to top and avoid both skipping items and processing nonexistent ones
moreover your code didn't update lastRow(n) of "tagret" sheets
do consider following code (untested, but commented)
Private Sub CommandButton1_Click()
'Declare variables
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim iRow As Long
'Set variables
Set sht1 = Sheets("To DO")
Set sht2 = Sheets("Ongoing")
Set sht3 = Sheets("Done")
With sht2
With Range("H1", .Cells(.Rows.Count, "H").End(xlUp)) 'reference its column H from row 1 down to last not empty one
iRow = .Rows.Count 'initialize row index from the bottom
Do
With .Cells(iRow, 1) 'reference referenced range cell in its current row
Select Case .Value
Case "Not started"
.Rows(iRow).Copy Destination:=sht1.Cells(sht1.Rows.Count, "A").End(xlUp)
.Rows(iRow).Delete
Case "Closed"
.Rows(iRow).Copy Destination:=sht3.Cells(sht3.Rows.Count, "A").End(xlUp)
.Rows(iRow).Delete
End Select
End With
iRow = iRow - 1
Loop While iRow >= 1
End With
End With
MsgBox "Update Done!"
End Sub

Excel VBA to summarize last cell of certain column to 'summary' worksheet

I am trying to summarize worksheets (invoices) into "Summary-Sheet" using below code that I found Internet. I am unsuccessfully trying to modify it to select last cell in column F (total amount) which represents total of each invoice.
Total in column F has varying row number based on items sold.
Please help me in updating code to it select total amount from last cell having value in column F.
Thank you!
Sub Summary_All_Worksheets_With_Formulas()
Dim Sh As Worksheet
Dim Newsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Delete the sheet "Summary-Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("Summary-Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Summary-Sheet"
Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets.Add
Newsh.Name = "Summary-Sheet"
'The links to the first sheet will start in row 2
RwNum = 1
For Each Sh In Basebook.Worksheets
If Sh.Name <> Newsh.Name And Sh.Visible Then
ColNum = 1
RwNum = RwNum + 1
'Copy the sheet name in the A column
Newsh.Cells(RwNum, 1).Value = Sh.Name
For Each myCell In Sh.Range("A1,A2,C3,E3,C4,E4,C5,E5") '<--Change the range
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
Next myCell
End If
Next Sh
Newsh.UsedRange.Columns.AutoFit
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
You do not need to loop through the cells to find your "total amount". I modified part of your code as follows:
If Sh.Name <> Newsh.Name And Sh.Visible Then
ColNum = 1
RwNum = RwNum + 1
'Copy the sheet name in the A column
Newsh.Cells(RwNum, 1).Value = Sh.Name
'put this declaration on top
Dim CellsArray() As String
Dim RangeString As String
Dim intCount As Integer
'your collection of ranges
RangeString = "A1,A2,C3,E3,C4,E4,C5,E5"
'split them into array
CellsArray = Split(RangeString, ",")
'loop through your array
For intCount = LBound(CellsArray) To UBound(CellsArray)
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & CellsArray(intCount) '<- access each range in array
Next intCount
'Find last row in the column: "Total Amount"
LastRow = Sh.Cells(Sh.Rows.Count, "F").End(xlUp).Row
'Assign that cell to myCell
Set myCell = Sh.Range("F" & LastRow)
'total
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
End If
Edit: I added the loop cycle in the middle as requested

Excel VBA code to find a certain cell and delete a section surrounding it

I am writing a macro in Excel. Part of the code finds the cell that has "Attached Packaging" in it and then deletes the contents of a group of cells surrounding that cell.
Here is the code that currently achieves this:
Cells.Find("Attached Packaging").Activate
ActiveCell.Resize(2, 4).Select
Selection.Clear
ActiveCell.Offset(1, -1).Select
Selection.Clear
My problem now is that I, unexpectedly, have multiple cells with "Attached Packaging" in them which now also have to be deleted.
So, to summarize: I need to modify this code so It finds all "Attached Packaging" cells in a spreadsheet and deletes the group around them.
Sub clear()
Dim ws As Worksheet
Dim search As String
Dim f As Variant
Dim fRow As Long
Dim fCol As Long
search = "Attached Packaging"
Set ws = ThisWorkbook.Worksheets("Sheet4") 'change sheet as needed
With ws.Range("A1:AA1000") 'change range as needed
Set f = .Find(search, LookIn:=xlValues)
If Not f Is Nothing Then
Do
fRow = f.Row
fCol = f.Column
ws.Range(Cells(fRow, fCol), Cells(fRow + 1, fCol + 3)).clear
ws.Cells(fRow + 1, fCol - 1).clear
Set f = .FindNext(f)
Loop While Not f Is Nothing
End If
End With
End Sub
Sub clearCells()
Dim ws As Worksheet
Dim lastrow As Long, currow As Long
Dim critvalue As String
Set ws = Sheets("Sheet1")
' Change A to a row with data in it
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
'Change 2 to the first row to check
For currow = 2 To lastrow
critvalue = "Attached Packaging"
' Change A to the row you are looking in
If ws.Range("A" & currow).Value = critvalue Then
' Use the currow to select the row and then create an offset
ws.Range("A" & currow).offset("B" & currow - 1).clear
ws.Range("A" & currow).offset("B" & currow + 1).clear
End If
Next currow
End Sub
Make the changes needed where I commented. It should work.

VBA Copy non-blank cells in EACH worksheet to existing worksheet

I don't even know where to start so I don't have any example code. I am thinking that I need a nested loop but that is what throws me off. I look forward to learning from everyone.
Here is what I'd like to do:
Begin with the worksheet named "John" and loop through each worksheet to the right.
On each worksheet, if a cell in column L is not blank, copy cell F and cell L for that row.
Append all of the copied cells to the worksheet "Notes". Paste the data from F on each sheet to column A and paste the corresponding data from L in column B. Add the copied data from each worksheet to the end of the data in "Notes".
I really appreciate any help, thanks!!
UPDATE
Based on Alter's great help and suggestions, this is what I have and it works perfectly. Thanks Alter!
Sub test()
Dim ws As Worksheet
Dim notes_ws As Worksheet
Dim row
Dim lastrow
Dim notes_nextrow
'find the worksheet called notes
For Each ws In Worksheets
If ws.Name = "Notes" Then
Set notes_ws = ws
End If
Next ws
'get the nextrow to print to
notes_nextrow = notes_ws.Range("A" & Rows.Count).End(xlUp).row + 1
'loop through other worksheets
For Each ws In Worksheets
'ignore the notes worksheet
If ws.Name <> "Notes" And ws.Index > Sheets("John").Index Then
'find lastrow
lastrow = ws.Range("L" & Rows.Count).End(xlUp).row
For row = 1 To lastrow
'if the cell is not empty
If IsEmpty(ws.Range("L" & row)) = False Then
notes_ws.Range("A" & notes_nextrow).Value = ws.Range("F" & row).Value
notes_ws.Range("B" & notes_nextrow).Value = ws.Range("L" & row).Value
notes_nextrow = notes_nextrow + 1
End If
Next row
End If
Next ws
End Sub
Nested loop indeed, you can use the code below as a basis for what you want to do
Public Sub test()
Dim ws As Worksheet
Dim notes_ws As Worksheet
Dim row
Dim lastrow
Dim notes_nextrow
'find the worksheet called notes
For Each ws In Worksheets
If ws.name = "Notes" Then
Set notes_ws = ws
End If
Next ws
'get the nextrow to print to
notes_nextrow = notes_ws.Range("A" & Rows.Count).End(xlUp).row + 1
'loop through other worksheets
For Each ws In Worksheets
'ignore the notes worksheet
If ws.name <> "Notes" Then
'find lastrow
lastrow = ws.Range("L" & Rows.Count).End(xlUp).row
For row = 1 To lastrow
'if the cell is not empty
If IsEmpty(ws.Range("L" & row)) = False Then
notes_ws.Range("A" & notes_nextrow).Value = ws.Range("L" & row).Value
notes_nextrow = notes_nextrow + 1
End If
Next row
End If
Next ws
End Sub