How to lock a column until it's last row with data - excel

I have date mentioned in cell A1, ex - "May".
I am now trying to lock rows 2-last with column Z which mentions date of joining of each employee and compares it to A1.
If month of this cell Z is > A1 then I am trying to lock the row. Not sure what to do.
Below code doesnt help :
Sub Lockrow()
Dim DestSh As Worksheet
Dim lastrow As Long
Dim i As Integer
Set DestSh = Sheets("Consultant & Teacher")
With DestSh
'finds the last row with data on A column
lastrow = Range("A65536").End(xlUp).Row
'parse all rows
For i = 6 To lastrow
'if your conditions are met
If Month(.Cells(i, 26)) > Month(.Cells(1, 2)) Then
.Range("A" & i).EntireRow.Cells.Locked = True 'lock the row
End If
Next i
End With
End Sub

Is this what you are trying?
Sub Sample()
Dim DestSh As Worksheet
Dim lastrow As Long
'~~> Change this as applicable
Set DestSh = Sheets("Sheet1")
With DestSh
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Columns("A:C").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
MsgBox "Insufficient rows"
Exit Sub
End If
.Unprotect "MyPassword"
.Cells.Locked = False
.Range("A6:C" & lastrow).Locked = True
.Protect "MyPassword"
End With
End Sub

Related

Copying last cell in a column and offsetting by 1

i have a code that copies an array of values from 1 sheet and pastes it in another now i want to offst the last populated row by 1 and delete the original row ie if the last row were L12:(entire row) it is pasted to L13 and row L12 is left empty.
Dim ws As Worksheet
Set ws = Worksheets("Pivot_WH calculations") 'change name as needed
With ws
'assumes data is in a "table" format with all data rows in column A and data columns in row 1
.Range("E2:J7").Copy _
Worksheets("WH Calc_new").Range("L" & .Rows.Count).End(xlUp).Offset(2)
.Range("E8:J8").Copy _
Worksheets("WH Calc_new").Range("L" & .Rows.Count).End(xlUp).Offset(2)
.Range("A2:A9").Copy _
Worksheets("WH Calc_new").Range("K" & .Rows.Count).End(xlUp).Offset(2)
End With
End Sub
The Function at the End will give you the last Row That is actually the last row used in the Worksheet.
For the offset you can change 2 to 3 or 4 or any other number you want to Offset in .Offset(Number_Here)
Try This:
Sub cdd()
Dim ws As Worksheet
Dim lst As Long
Set ws = Worksheets("Pivot_WH calculations") 'change name as needed
lst = LastRow(Worksheets("WH Calc_new"))
With ws
.Range("E2:J7").Copy Worksheets("WH Calc_new").Range("L" & lst).Offset(2)
.Range("E8:J8").Copy Worksheets("WH Calc_new").Range("L" & lst).Offset(2)
.Range("A2:A9").Copy Worksheets("WH Calc_new").Range("K" & lst).Offset(2)
End With
End Sub
Function LastRow(Sh As Worksheet)
On Error Resume Next
LastRow = Sh.Cells.Find(What:="*", _
After:=Sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
On Error GoTo 0
End Function

VBA Find #N/A value and copy adjacent cells to another sheet and loop

Good day to everyone,
I have been trying to find an answer here that would fit my problem but I have been unsuccessful. I am using FIND to search column F for cell with #N/A value and copy adjacent cells to another "Sheet2" at the end of the column A. I have made the following code that works but my problem is I want to make it to loop to find the next cell with #N/A value till find all.
Sub Find()
Dim SerchRange As Range
Dim FindCell As Range
Set SerchRange = Range("F:F")
Set FindCell = SerchRange.FIND(What:="#N/A", _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FindCell Is Nothing Then
MsgBox "Nothing was found all clear"
Else
FindCell.Select
ActiveCell.Offset(0, -3).Resize(, 3).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
End Sub
Try this and let me know if it works:
Option Explicit
Sub Find()
Application.ScreenUpdating = False
Dim SearchRange As Range
Dim FindCell As Range
Dim Check As Boolean
Dim LastRow As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim FindCounter As Long
Set ws = ThisWorkbook.Worksheets("Sheet1") ' <--- Insert the name of your worksheet here
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = ws.Cells(Rows.Count, "F").End(xlUp).Row ' <--- Finds the last used row
Set SearchRange = Range("F1:F" & LastRow)
FindCounter = 0
For Each FindCell In SearchRange
If FindCell.Value = "#N/A" Then
FindCounter = FindCounter + 1
FindCell.Offset(0, -3).Resize(, 3).Copy
ws2.Range("A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
MsgBox "Succes!" & vbNewLine & vbNewLine & "This many cells were found: " & FindCounter
Application.ScreenUpdating = True
End Sub

How to accelerate an Excel VB Macro

I am trying to accelerate my Excel VB Macro.
I have tried the 5 alternatives below.
But I wonder if I could shorten the execution further.
I found 2 alternatives in User Blogs which I could not get to work.
One alternative is also found in a User Blog but do not understand.
Sub AccelerateMacro()
'
' v1 052817 by eb+mb
' Macro to copy as fast as possible sheet from one workbook into another workbooks
' Declarations for variables are not shown to make code example more legible
' Macro is stored in and run from "DestinationWorkBook.xlsm"
StartTime = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Alternative = "First"
If Alternative = "First" Then
Workbooks.Open Filename:="SourceWorkBook.xls"
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Windows("SourceWorkBook.xls").Activate
ActiveWorkbook.Close
End If
If Alternative = "Second" Then
Workbooks.Open Filename:="SourceWorkBook.xls", ReadOnly:=True
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Workbooks("SourceWorkBook.xls").Close SaveChanges:=False
End If
If Alternative = "Third" Then
' I could not get this alternative to work
Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet").Copy
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1").PasteSpecial
End If
If Alternative = "Fourth" Then
' I could not get this alternative to work
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1") = Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet")
End If
If Alternative = "Fifth" Then
' I don't understand the code in this alternative
Dim wbIn As Workbook
Dim wbOut As Workbook
Dim rSource As Range
Dim rDest As Range
Set wbOut = Application.Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Application.Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet").UsedRange
wbOut.Sheets("DestinationSheet").Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Instead of using UsedRange, find the actual Last Row and Last Column and use that range. UsedRange may not be the range that you think it is :). You may want to see THIS for an explanation.
See this example (UNTESTED)
Sub Sample()
Dim wbIn As Workbook, wbOut As Workbook
Dim rSource As Range
Dim lRow As Long, LCol As Long
Dim LastCol As String
Set wbOut = Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet")
'~~> Find Last Row
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find Last Column
LCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Column Number to Column Name
LastCol = Split(Cells(, LCol).Address, "$")(1)
'~~> This is the range you want
Set rSource = .Range("A1:" & LastCol & lRow)
'~~> Get the values across
wbOut.Sheets("DestinationSheet").Range("A1:" & LastCol & lRow).Value = _
rSource.Value
End With
End Sub

Merging sheets in to a master sheet

I got the following code from Ron de Bruin's site and it works pretty much fine for pulling data into a master sheet, and updating the master sheet whenever there are changes in the other sheets.
But I would like to copy only certain columns of data. For example my sheets have data from A:Z but i only need the A:P data in my master sheet.
Any help on this will be greatly appreciated and please know that im a non-coder, so please be specific about what to change and where to change it.
Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "Master Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Master Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Master Sheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master Sheet"
'Fill in the start row
StartRow = 2
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A1:Z1").Copy DestSh.Range("A1")
End If
'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)
'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Actually you just have to change the code that defines the area that should be copied. In your case you have to check the "ranges" before copying the data:
sh.Range("A1:Z1").Copy DestSh.Range("A1")
That line takes care of the headlines, so you can replace the Z1 with e. g. P1.
The next range is to copy the data:
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
Here you can use the existing functionality to get the correct start row and last row. But instead of selecting the complete rows you will just select a part of the sheet:
sh.Range("A" & StartRow & ":P" & shLast)
That should do the trick.
P. S. Even If you are not a programmer. Have a look at the VBA Basics, its not that hard and you can do a lot of cool stuff if you know how it works... :)

Excel Vba - Copy row if value in cell is greater than

I've got this table full of data. And column K in each row contains a number. So basically what I'm trying to do is move that entire row, if the data in that column is greater than 9, over to sheet2.
How can this be achieved? I've already created actual tables in the sheets, called Table1 and Table2.
This is what I've managed to put together so far. I've looked at autofilter, but I can't understand squat of what's happening in there. So this I get!
Sub MoveData()
Dim i As Range
Dim num As Integer
num = 1
For Each i In Range("K10:K1000")
If i.Value > 9 Then
i.Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet2").Range("A65000").End(xlUp).Offset(num, 0).PasteSpecial
ActiveCell.Rows.Delete
num = num + 1
End If
Next i
End Sub
This kinda works so far. But I can't manage to paste the row to the next blank row in sheet2. I tried doing that num = num + 1 thing, but I guess that's way off?
Is this what you are trying? (TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim rRange As Range
Dim lastRowWsO As Long
Set wsI = Sheets("sheet1")
'~~> Assuming that the Header is in K10
Set rRange = wsI.Range("K10:K1000")
Set wsO = Sheets("sheet2")
'~~> Get next empty cell in Sheet2
lastRowWsO = wsO.Range("A" & Rows.Count).End(xlUp).Row + 1
With wsI
'~~> Remove Auto Filter if any
.AutoFilterMode = False
With rRange
'~~> Set the Filter
.AutoFilter Field:=1, Criteria1:=">=9"
'~~> Temporarirly hide the unwanted rows
wsI.Rows("1:9").EntireRow.Hidden = True
wsI.Rows("1001:" & Rows.Count).EntireRow.Hidden = True
'~~> Copy the Filtered rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
wsO.Rows(lastRowWsO)
'~~> Delete The filtered rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Unhide the rows
.Rows("1:9").EntireRow.Hidden = False
.Rows("1001:" & Rows.Count).EntireRow.Hidden = False
'~~> Remove Auto Filter
.AutoFilterMode = False
End With
End Sub
NOTE: I have not included any error handling. I would recommend you to include one in the final code
FOLLOWUP
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim rRange As Range
Dim lastRowWsI As Long, lastRowWsO As Long
Set wsI = Sheets("Risikoanalyse")
'~~> Assuming that the Header is in K10
Set rRange = wsI.Range("K9:K1000")
lastRowWsI = wsI.Cells.Find(What:="*", _
After:=wsI.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Set wsO = Sheets("SJA utarbeides")
'~~> Get next empty cell in Sheet2
lastRowWsO = wsO.Cells.Find(What:="*", _
After:=wsO.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
With wsI
With .ListObjects("TableRisikoAnalyse")
'~~> Set the Filter
.Range.AutoFilter Field:=11, Criteria1:=">=9"
'~~> Temporarirly hide the unwanted rows
wsI.Rows("1:8").EntireRow.Hidden = True
wsI.Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = True
'~~> Copy the Filtered rows
wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, "$9:$9,", "")).EntireRow.Copy _
wsO.Rows(lastRowWsO)
'~~> Clear The filtered rows
wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, "$9:$9,", "")).Clear
.Range.AutoFilter Field:=11
'~~> Sort the table so that blank cells are pushed down
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("TableRisikoAnalyse[[ ]]"), SortOn:=xlSortOnValues, Order _
:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'~~> Unhide the rows
.Rows("1:8").EntireRow.Hidden = False
.Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = False
'~~> Remove Auto Filter
.AutoFilterMode = False
End With
End Sub

Resources