Im trying to lock a few ranges of cells to prevent them from being altered outside of the button press.
I have the following code so far:
Private Sub DateRangePayer()
Dim unionRange As Range, uRng As Range, EssentialWrite As Range, chCell As Range, chRng As Range
Dim d As Long, k As Long, x As Long
ActiveSheet.Unprotect
Set EssentialWrite = Sheets("Essential Info").Range("E2:E6")
Set unionRange = ActiveSheet.Range("Q8:R12, T8:T12, Q16:R20, T16:T20")
Set chRng = ActiveSheet.Range("Q8:R12, T8:T12, Q16:R20, T16:T20")
x = Sheets("Essential Info").Range("G19").Value
ReDim OArr(1 To 5, 1 To 1) As Variant
For d = DateSerial(Year(x), Month(x), 1) To DateSerial(Year(x), Month(x) + 1, 0) - 1
If Weekday(d, vbSunday) = 7 Then
k = k + 1
OArr(k, 1) = d
End If
Next d
If k = 4 Then OArr(k + 1, 1) = "-"
For Each uRng In unionRange.Areas
uRng.Value = OArr
uRng.NumberFormat = "dd-mmmm"
Next uRng
For Each chCell In chRng.Cells
chCell.MergeArea.Locked = (chCell.Value <> "")
Next chCell
EssentialWrite.Value = OArr
EssentialWrite.NumberFormat = "dd-mmmm"
ActiveSheet.Protect
End Sub
The main parts of the code are the
ActiveSheet.Unprotect
For Each chCell In chRng.Cells
chCell.MergeArea.Locked = (chCell.Value <> "") Next chCell
ActiveSheet.Protect
Currently the code executes with zero errors. However the range of cells is not locked at all and is actually editable in its entirety.
Im doing this to prevent unexpected user entries in the specified cells
Any advice on what may work.
Im sorry if the code is a little messy. Im kinda just hacking together at this point and relatively new to this
This code locks only the code that say LOCKED in the image below.
Sub lockCells()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
ws.Cells.Locked = False
Dim rng As Range
Set rng = ws.Range("A1:A10")
Dim cell As Range
For Each cell In rng
cell.Locked = cell.Value <> ""
Next cell
ws.Protect 1234
End Sub
I'm not sure this is 'best practice' but I'd use:
chCell.Cells(1, 1).Locked = (chCell.Value <> "")
Related
Hello I am trying to copy a range into a single column. The range is a mix of blank cells and cells with values.I only want to copy and paste the cells with values and I would it to find the first blank cell and want it to walk itself down the column from there.
The code I have right now (besides taking forever) pastes in the first row.
Dim i As Integer
i = 1
ThisWorkbook.Worksheets("amount date").Select
For Row = 51 To 100
For col = 2 To 1000
If Cells(Row, col).Value <> "" Then
Cells(Row, col).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
End If
Next
Next
Do While Worksheets("sheet 2").Range("G" & i).Value <> ""
i = i + 1
Loop
End Sub
This will work:
Sub qwerty()
Dim i As Long, r As Long, c As Long
i = 1
ThisWorkbook.Worksheets("amount date").Select
For r = 51 To 100
For c = 2 To 1000
If Cells(r, c).Value <> "" Then
Cells(r, c).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
i = i + 1
End If
Next
Next
End Sub
Perhaps this will be a little faster (even though it seems to have been slow arriving).
Sub CopyRangeToSingleColumn()
' 20 Oct 2017
Dim LastRow As Long
Dim LastClm As Long
Dim Rng As Range, Cell As Range
Dim CellVal As Variant
Dim Spike(), i As Long
With ThisWorkbook.Worksheets("amount date")
With .UsedRange.Cells(.UsedRange.Cells.Count)
LastRow = Application.Max(Application.Min(.Row, 100), 51)
LastClm = .Column
End With
Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm))
End With
ReDim Spike(Rng.Cells.Count)
For Each Cell In Rng
CellVal = Trim(Cell.Value) ' try to access the sheet less often
If CellVal <> "" Then
Spike(i) = CellVal
i = i + 1
End If
Next Cell
If i Then
ReDim Preserve Spike(i)
With Worksheets("sheet 2")
LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2)
.Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike)
End With
End If
End Sub
The above code was modified to append the result to column G instead of over-writing existing cell values.
Do you need copy the whole row into one cell, row by row? For each loop shall be faster. I guess, this should work
Sub RowToCell()
Dim rng As Range
Dim rRow As Range
Dim rRowNB As Range
Dim cl As Range
Dim sVal As String
Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range
For Each rRow In rng.Rows
On Error Resume Next
Set rRowNB = rRow.SpecialCells(xlCellTypeConstants)
Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow)
On Error GoTo 0
For Each cl In rRowNB.Cells
sVal = sVal & cl.Value
Next cl
Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal
sVal = ""
Next rRow
End Sub
its quick for this range.
I want to compare three worksheets (which should be identical) in a workbook and highlight any non-matching cells. I've based the following code on Using VBA to compare two Excel workbooks:
Sub CompareWorksheets()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim varSheetC As Worksheet
Dim varSheetAr As Variant
Dim varSheetBr As Variant
Dim varSheetCr As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Set varSheetA = Worksheets("DS")
Set varSheetB = Worksheets("HT")
Set varSheetC = Worksheets("NM")
strRangeToCheck = ("A1:L30")
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
varSheetCr = varSheetC.Range(strRangeToCheck).Value ' or whatever your other sheet is.
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
Debug.Print iRow, iCol
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) And varSheetAr(iRow, iCol) = varSheetCr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetC.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetC.Cells(iRow, iCol).Interior.ColorIndex = 22
End If
Next
Next
End Sub
The problem is, when "strRangeToCheck" starts at A1, everything works as it should, but as soon as I change the range to something like ("B4:C6"), it looks like the correct comparisons are still being made, but the cells that get highlighted always get shifted back up to cell A1 as the starting point (as opposed to B4, which is what I want). In other words, the highlighting "pattern" is correct, but shifted up and over a few cells.
I expanded on #Vityata example.
CompareWorksheets compares the same range on up to up to 60 Worksheets, whereas CompareRanges will compare ranges of the same size and shape.
Sub Test_Comparisons()
CompareWorksheets "A1:L30", Worksheets("DS"), Worksheets("HT"), Worksheets("NM")
CompareRanges Worksheets("DS").Range("A1:L30"), Worksheets("HT").Range("K11:V40"), Worksheets("NM").Range("A101:L130")
End Sub
Sub CompareWorksheets(CompareAddress As String, ParamArray arrWorkSheets() As Variant)
Application.ScreenUpdating = False
Dim cell As Range
Dim x As Long
Dim bFlag As Boolean
'Reset all the colors
For x = 0 To UBound(arrWorkSheets)
arrWorkSheets(x).Range(CompareAddress).Interior.ColorIndex = xlNone
Next
For Each cell In arrWorkSheets(0).Range(CompareAddress)
bFlag = False
For x = 1 To UBound(arrWorkSheets)
If arrWorkSheets(x).Range(cell.ADDRESS).Value <> cell.Value Then
bFlag = True
Exit For
End If
Next
If bFlag Then
For x = 0 To UBound(arrWorkSheets)
arrWorkSheets(x).Range(cell.ADDRESS).Interior.ColorIndex = 22
Next
End If
Next
Application.ScreenUpdating = True
End Sub
Sub CompareRanges(ParamArray arrRanges() As Variant)
Application.ScreenUpdating = False
Dim cell As Range
Dim x As Long, y As Long, z As Long
Dim bFlag As Boolean
'Reset all the colors
For z = 0 To UBound(arrRanges)
arrRanges(z).Interior.ColorIndex = xlNone
Next
For x = 1 To arrRanges(0).Rows.Count
For y = 1 To arrRanges(0).Rows.Count
For z = 1 To UBound(arrWorkSheets)
If arrWorkSheets(1).Cells(x, y).Value <> arrWorkSheets(z).Cells(x, y).Value Then
bFlag = True
Exit For
End If
Next
If bFlag Then
For z = 0 To UBound(arrWorkSheets)
arrWorkSheets(z).Cells(x, y).Interior.ColorIndex = 22
Next
End If
Next
Next
Application.ScreenUpdating = True
End Sub
What I have understood from the first reading, is that you have 3 worksheets which you want to compare. This code works, if you want to compare a selected range in the first three worksheets in a workbook. It colors the different values in red, in each workbook:
Option Explicit
Sub compareWorksheets()
Dim rngCell As Range
Dim counter As Long
For Each rngCell In Selection
If Worksheets(1).Range(rngCell.Address) <> Worksheets(2).Range(rngCell.Address) _
Or Worksheets(1).Range(rngCell.Address) <> Worksheets(3).Range(rngCell.Address) Then
For counter = 1 To 3
Worksheets(counter).Range(rngCell.Address).Interior.Color = vbRed
Next counter
End If
Next rngCell
End Sub
If you want to compare a range A1:Z10 in the three worksheets, change the words Selection with Worksheets(1).Range("A1:Z10") or simply select the range in a one workbook.
I have this code. DataSet is set as a variant.
DataSet = Selection.Value
Works fine but is there a way I can change it to just column A, specifically cells A2 to A502? Ive tried setting that as the range but it doesn't work. It also needs to ignore blank spaces because not all of the cells will have content. I am trying to eliminate the need to highlight the cells as the entries will only be in that specific range.
Try these 2 versions:
Option Explicit
Public Sub getNonemptyCol_ForLoop()
Dim dataSet As Variant, fullCol As Variant, i As Long, j As Long
Dim lrFull As Long, lrData As Long, colRng As Range
Set colRng = ThisWorkbook.Worksheets(1).Range("A2:A502")
fullCol = colRng
lrFull = UBound(fullCol)
lrData = lrFull - colRng.SpecialCells(xlCellTypeBlanks).Count
ReDim dataSet(1 To lrData, 1 To 1)
j = 1
For i = 1 To lrFull
If Len(fullCol(i, 1)) > 0 Then
dataSet(j, 1) = fullCol(i, 1)
j = j + 1
End If
Next
End Sub
Public Sub getNonemptyCol_CopyPaste() 'without using a For loop
Dim dataSet As Variant, ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets(1)
With ws.UsedRange
ws.Activate
.Range("A2:A502").SpecialCells(xlCellTypeConstants).Copy
.Cells(1, (.Columns.Count + 1)).Activate
ActiveSheet.Paste
dataSet = ws.Columns(.Columns.Count + 1).SpecialCells(xlCellTypeConstants)
'dataSet now contains all non-blank values
ws.Columns(.Columns.Count + 1).EntireColumn.Delete
.Cells(1, 1).Activate
End With
Application.ScreenUpdating = True
End Sub
Assign with dynamic column.
Sub SetActiveColunmInArray()
Dim w As Worksheet
Dim vArray As Variant
Dim uCol As Long
Dim address As String
Set w = Plan1 'or Sheets("Plan1") or Sheets("your plan name")
w.Select
uCol = w.UsedRange.Columns.Count
address = w.Range(Cells(1, 1), Cells(1, uCol)).Cells.address
vArray = Range(address).Value2
End Sub
I have columns A, B, C, D, and E with data.
My goal is to start in cell A1, loop through every single record in column A while looking for a particular value "Grey". If the text in cells is equal to "Grey" then i want to cut and paste then entire row to a newly created sheet, starting in A1. here's what my code looks like ....
Dim n As Long
Dim nLastRow As Long
Dim nFirstRow As Long
Dim lastRow As Integer
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
Worksheets("Original").Activate
With Application
.ScreenUpdating = False
Sheets.Add.Name = "NewSheet"
Sheets("Original").Select
Range("A1").Select
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
With ActiveSheet
For n = nLastRow To nFirstRow Step -1
If .Cells(n, "A") = "Grey" Then
.Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")
.Cells(n, "A").EntireRow.Delete
n = n + 1
End If
Next
End With
.ScreenUpdating = True
End With
So this macro creates a new sheet - however when it gets to a cell where the value is grey it gives me an error on this line....
.Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")
Error says:
Application defined or object defined error.
Anyone have any idea why?
You need to declare i, and set it. As mentioned, the first time it occurs it's looking to paste in row 0, which doesn't exist.
Also, it's best to avoid using .Select/.Activate, and work directly with the data.
How does this work?
Sub t()
Dim r As Range
Dim n As Long, i As Long, nLastRow As Long, nFirstRow As Long
Dim lastRow As Integer
Dim origWS As Worksheet, newWS As Worksheet
Set origWS = Worksheets("Original")
Set newWS = Sheets.Add
newWS.Name = "NewSheet"
Set r = origWS.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row
i = 1
With Application
.ScreenUpdating = False
With origWS
For n = nLastRow To nFirstRow Step -1
If .Cells(n, "A") = "Grey" Then
.Cells(n, "A").EntireRow.Copy newWS.Cells(i, "A")
.Cells(n, "A").EntireRow.Delete
i = i + 1
End If
Next
End With
.ScreenUpdating = True
End With
End Sub
You also don't need to do n = n + 1 (unless I missed something).
Edit: Changed .Cut to .Copy, per OP's wish to keep formatting.
Or you may try something like this...
Sub CopyToNewSheet()
Dim sws As Worksheet, dws As Worksheet
Application.ScreenUpdating = False
Set sws = Sheets("Original")
On Error Resume Next
Set dws = Sheets("NewSheet")
dws.Cells.Clear
On Error GoTo 0
If dws Is Nothing Then
Sheets.Add(after:=sws).Name = "NewSheet"
Set dws = ActiveSheet
End If
sws.Rows(1).Insert
On Error Resume Next
With sws.Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:="Grey"
.SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
dws.Rows(1).Delete
Application.ScreenUpdating = True
End Sub
I can't get this to loop through to the next row. The inner two loops are working fine from what i can tell using the debugger but it never goes to the next row. Any help would be appreciated.
Sub PopulateData()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim locationRow As Integer
Set s1 = ThisWorkbook.Sheets("Order_LVL")
Set s2 = ThisWorkbook.Sheets("sheet1")
Dim Lastrow As Integer
Lastrow = s1.Cells(Rows.Count, 1).End(xlUp).Row
Dim iRow As Integer
For iRow = 1 To Lastrow
Dim cellj As Range
For Each cellj In s1.Range("B:F")
locationRow = 1
Dim celli As Range
For Each celli In s2.Range("B1:F1")
Dim currentrow As Long
currentrow = iRow + 1
If s1.Cells(currentrow, cellj.Column).Value = 0 Then
ElseIf s1.Cells(currentrow, cellj.Column).Value <> s2.Cells(locationRow, celli.Column).Value And s2.Cells(currentrow, celli.Column).Value = 0 Then
s2.Cells(currentrow, celli.Column).Value = 0
Else: s2.Cells(currentrow, celli.Column).Value = 1 'indicates that this order features a line from this location
End If
Next celli
Next cellj
Next iRow
End Sub
Can you try this on some test data (Note I haven't tested it myself but re-written it with only two loops)
Sub PopulateData()
Dim s1 As Worksheet: Dim s2 As Worksheet
Dim rng As range: Dim rng2 As range
Dim cell: Dim header
With Application
.ScreenUpdating = False
End With
With ThisWorkbook
Set s1 = .Sheets("Order_LVL")
Set s2 = .Sheets("sheet1")
End With
With s1
Set rng = range(.Cells(1, 2), .Cells(.Cells(Rows.Count, 6).End(xlUp).Row, 6)) ' Used Range in Order_LVL
End With
Set rng2 = range(s2.Cells(1, 2), s2.Cells(1, 6)) 'Header range in sheet1
For Each cell In rng.Cells
For Each header In rng2.Cells
If cell.value = 0 Then
ElseIf cell.value <> header.value And s2.Cells(cell.Row, header.Column).value = 0 Then
s2.Cells(cell.Row, header.Column).value = 0 ' Not sure why you're doing this - if it is already 0 why set it back to 0. Left it in for continuity
Else
s2.Cells(cell.Row, header.Column).value = 1 ' indicates that this order features a line from this location
End If
Next header
Next cell
With Application
.ScreenUpdating = True
End With
End Sub
It should do what you want if I've understood correctly.