I have a sheet where employees enter a reservation on each row in Excel. I'm trying to create code that will prevent them from skipping rows.
I have a formula in Col W that determines how many cells were filled out in a particular row (Col C:K) so that the row has at least most the info needed. I have a worksheet change event within that sheet that when the formula reaches 6, the code should unlock the next row of Col C:K, allowing the user to use the next row. My code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim c As Range
Set rng = Range("W6:W504")
For Each c In rng
If c.Value >= 6 Then
Worksheets("January").Unprotect Password:="XXX"
c.Offset(1, -20).Resize(0, 8).Locked = False 'should unlock C7:K7
End If
Next c
End Sub
I've tried to combine the offset and resize lines, enter them on separate lines, select them then apply the unlock, but all to no avail. The closest I've come is to separate the offset and resize, and select the appropriate cell on the next row (C7), but I can't get it to resize then apply the lock. Thanks!
Related
I have financial data where some rows are blank and id like to be able to delete the entire row IF entire rows in a selected range are blank (its important for it to be in selected range as I might have "Revenues" in column A but then I have column B-D be blank data (no numbers basically)).
I'd like for it to apply to a selected range, instead of having a predetermined range in the code (for the code to be flexible).
I am trying to use this format but it doesnt seem to be working:
Sub deleteBlankRows()
Dim c As Range
On Error Resume Next
For Each c In Selection.Row.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next
End Sub
Any thoughts would be welcome.
Loop trough each complete row of selection and check if the count of blank cells matchs the count of all cells in row:
My code:
Dim rng As Range
For Each rng In Selection.Rows
If Application.WorksheetFunction.CountBlank(rng) = rng.Cells.Count Then rng.EntireRow.Delete
Next rng
After executing code:
The emtpy row is gone
UPDATE:
#VasilyIvoyzha is absolutely right. For each won't work properly on this situation. A better approach would be:
Dim i&, x&, lastRow&
lastRow = Range(Split(Selection.Address, ":")(1)).Row
x = Selection.Rows.Count
For i = lastRow To Selection.Cells(1).Row Step -1
If WorksheetFunction.Concat(Selection.Rows(x)) = "" Then Rows(i).Delete
x = x - 1
Next i
This way will delete empty rows on selection, even if they are consecutive.
SETUP:
Start with a sheet that has 3 columns. "ID", "MyNote", "MyDate" headers. This sheet may have thousands of rows of data.
I need to "flag" any row where the user has made a change to anything on the row. In other code the flagged rows will be in turn be used to update a table on my SQL server.
Typically there will only be a few rows the user would change/update in a session. So I don't want to process every row in the sheet, particularly the ones with no changes.
WHAT I HAVE WORKING NOW:
I have done this successfully by writing a "x" to an additional "flag" column any time the user makes a change. Then later I can process any rows that were flagged with a "x" . I did this using:
Private Sub Worksheet_Change(ByVal Target As Range)
...
' Flag any lines with a change
If Not Intersect(Target, Me.Range(TestForChangeColRange)) Is Nothing Then
Application.EnableEvents = False
' Set the "Pending Write" Flag
Target.Worksheet.Range(PendingWriteCol & Target.Row).Value = "x"
Application.EnableEvents = True
...
PROBLEM:
That works great for individual cells being updated one at a time. The problem comes when a user either a) uses the drag and copy (drag the bottom right corner of a cell to replicate it where dragged), or b) with a paste from some other workbook, in either case more than one cell is changed at a time.
In those cases, the Worksheet_Change sees only the first cell and not any extra cells edited by dragging or pasting.
I tried to find other similar solutions for intercepting Copy/Paste, etc., but I can't see anyway to find that if a copy was made, which cells were affected.
NEED:
All I need to know is which row numbers were affected from a drag or a copy/paste. If I can accurately flag those rows as updated, I'm in business.
FOLLOW-UP
Using Tim's solution. Having trouble melding something back into it.
Additionally I need to be able to check if a particular column was edited and if it was, clear a different column. For example, if Col 2 is edited, clear the contents of Col 3.
I tried adding the test inside the For loop, but my colno for rw.Col is coming out off.
If Not rng Is Nothing Then
'expand the range so we can flag by row, and not cell-by-cell
Set rng = Application.Intersect(rng.EntireRow, rngTbl)
For Each rw In rng.Rows 'loop over affected rows
Me.Cells(rw.Row, PendingWriteCol).Value = "x"
If rw.Column = RequestTypeCol Then
Me.Cells(rw.Row, LastColToClear).ClearContents
End If
Next rw
End If
Can you show me what I've done wrong?
For example (following on from Scott's comment):
Private Sub Worksheet_Change(ByVal Target As Range)
Const PendingWriteCol As Long = 4
Const TestForChangeColRange = "A:C"
Dim rw As Range, rng As Range, rngTbl As Range
Set rngTbl = Me.Range(TestForChangeColRange)
Set rng = Application.Intersect(Target, rngTbl) 'any monitored cells affected?
If Not rng Is Nothing Then
'expand the range so we can flag by row, and not cell-by-cell
Set rng = Application.Intersect(rng.EntireRow, rngTbl)
For Each rw In rng.Rows 'loop over affected rows
Me.Cells(rw.Row, PendingWriteCol).Value = "x"
Next rw
End If
End Sub
When formula result changes in my table in column K range ("K2:K5") I want the entire row in the table to be filled with a color. But I only want the row to be colored if the result is not equal to 0.
So eg. if the result changes in K2 (and is not = 0) the entire row A2:L2 will be colored.
The formula are refering to values that you select from dropdown-lists (created from "data validation" on the excel menu Data-tab). These dropdowns are located on the same row (eg. “D2:J2”) as the related formula. The values in the dropdown is refering to a range on the same sheet outside of the table.
So far I have one code for the worksheet concerning the change event that calls the module with the sub that will change the color on the row.
But it doesn't work and I get no error messages.
This is the code for the worksheet change event:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "§D2:§J2" Then
Color_Row
End If
End Sub
Here the target address should propably be the whole range, but I don't know how to give the right syntax for that.
Here is the code for changing color on row:
Sub Color_Row()
Dim r As Long, c As Long 'r=rows in the excel sheet | c= value of cell in _
column k
Dim numrow As Long 'last row with data
Dim tblR As Long 'tablerow
numrow = TimeMeasure.Range("K" & Rows.Count).End(xlUp).Row
For r = 2 To numrow
tblR = r - 1
c = Cells(r, 11).Value
If c <> 0 Then
[TimeDist].Rows(tblR).Interior.Color = 12961279
Else
[TimeDist].Rows(tblR).Interior.Color = xlNone 'no fill color
End If
Next
End Sub
I have steped in to this code and watched variables like c, r, numrow, tblR and it all seems to match my table (the name of my table is TimeDist).
The only thing that I've noticed is that no values ever assigns to c in the loop. I know though that this code works in another workbook, but then I manualy type in a new value in a specific cell outside of the table, which changes the formula result in table (then the rows get colored)
I very thankfuly accept any help on this.
Many thanks for all your inputs which has helped me to solve it! :)
It now works like a charm!
This worksheet_calculate code does the job (I have changed my cell range though):
Private Sub Worksheet_Calculate()
Dim Xrg As Range
Set Xrg = Range("L2:L5")
If Not Intersect(Xrg, Range("L2:L5")) Is Nothing Then
Color_Row
End If
End Sub
So I'm working on an excel sheet, and this is something i really can't figure out.
I want it to be that if the contents of a cell match certain criteria, an entire column of cells will be pasted according to that cell. The cell is a drop down with 32 different options (that can be reduced if theres no way to do it) and each option corresponds to a different column of data. The columns that have to be pasted have roughly 32 cells of data each.
My current formula is basically =IFS(A1="Potato",Sheet2!G:G) but this gives me a '0'. The best i can do is change the formula to =IFS(A1="Potato",Sheet2!G1) or =IFS(A1="Potato",Sheet2!G1:G32) but both of these formulas give me the contents of the first cell only (G1).
Any ideas on how I could get this done without having to contact aliens or build a spaceship?
You can use formulas, or VBA.
I have assumed your 32 columns of source data are in Sheet2 with the headers in row 1.
Formula Solution
In Sheet1 A73, enter:
=INDEX(Sheet2!$A$1:$AF$41,ROW(A1),MATCH($A$1,Sheet2!$A$1:$AF$1,0))
Copy this formula to Sheet1 A74:A105
VBA Solution
Put this code in the Sheet1 module;
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Target, Range("A1")) Is Nothing Then
Application.EnableEvents = False
With Sheet2
Set c = .Rows(1).Find(what:=Sheet1.Range("A1").Value)
If Not c Is Nothing Then
Set c = Intersect(.UsedRange, c.EntireColumn)
Sheet1.Range("A73").Resize(c.Rows.Count, 1).Delete
c.Copy Sheet1.Range("A73")
End If
End With
Application.EnableEvents = True
End If
End Sub
EDITED ANSWER: (according to comment)
We have the following layout of products
Private Sub CommandButton1_Click()
'first we check the user input
Dim u_input As String
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
u_input = LCase(Trim(ws.Range("A1").Value2))
'now we need to determine how many columns there are so we know when to stop looping
Dim lc As Long, lr As Long
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' loops through all the products
For Each cell In Range(Cells(1, "F"), Cells(1, lc))
' if the product matches the input
If LCase(Trim(cell)) = u_input Then
lr = ws.Cells(ws.Rows.Count, cell.Column).End(xlUp).Row
' copy and paste the active data range to A37
ws.Range(Cells(1, cell.Column), Cells(lr, cell.Column)).Copy
Sheets("Sheet2").Range("A37").PasteSpecial
End If
Next cell
End Sub
So, upon entering cucumber and clicking the button:
We would get the following result:
You can add any number of products there, as long as the first product starts in column F. (though that can also be changed in code).
PS: This will however end up overwriting your data and also cause data to overlap if your data ranges are not the same. It probably would be smarter to paste the data into the next empty row in sheet2 instead of directly to A37
This can be achieved by changing the line
Sheets("Sheet2").Range("A37").PasteSpecial to Sheets("Sheet2").Range(Cells((Rows.Count, "A").End(xlUp).Row, "A")).PasteSpecial
I have a template that's linking to external source.
My predecessor created it and that for 'easiness' on the eye, he/she created it by skipping a row. i.e. row 1 then row 3, row 5, row 9, row 13 etc HAS FORMULA, whereas in between those mentioned rows are just DEFAULT EMPTY CELL.
I've created a vba that opens the workbook and copy the sheet that I want.
If I were to use the code below, it's running very slowly, and for some reason, it loops more than once.
for each cell in usedrange
if cell.hasformula = true and instr(cell.formula, "SUMIF") > 0 then
cell.formulaR1C1 = "='\\tel\folder1\folder2\[xlsheet.xlsx]SheetName'!RC
end if
next cell
Therefore, what I've done is to actually assign it once, copy it and then paste to the respective cells (as shown below).
Workbooks(desWB).Sheets(maxSheet + 1).Range("J5").FormulaR1C1 = fullPath
Workbooks(desWB).Sheets(maxSheet + 1).Range("J5").Copy
Workbooks(desWB).Sheets(maxSheet + 1).Range("J6:J12,E48:J55,E57:J58,E61:J79,E84:J93,E96:J96,E99:J103").PasteSpecial Paste:=xlPasteFormulas
The latter method works and it's definitely much faster than the first. However, now I am facing a situation where due to the setup of the template, some rows have formulas and some doesn't, and it goes to thousands of rows. The skipping of rows too sometimes is not an increment of 2, it could be 3, 5 etc.
So am wondering if there's a way that's more effective and efficient to:
Look at the used range
If range has formula AND formula has 'SUMIF'
Change the formula to something else
Else SKIP and check next cell
If you only want to process rows where the first cell in that row has a non-empty cell value then you should iterate the Ranges rows and columns and skip the rows when the first cell fails the test.
Your current code that uses a For Each cell in range approach will still keep processing cells in an empty row - which is redundant.
You can use code like below to skip the blank rows and only apply conditional logic to rows where you are confident that some cells have the formula you want to update. In the example, I use Range("C4:E10") but you can substitute for the Range that works for you depending on your workbook structure.
Option Explicit
Sub Test()
'could pass in UsedRange of the sheet...
IterateRange ThisWorkbook.Worksheets("Sheet1").Range("C4:E10")
End Sub
Sub IterateRange(rng As Range)
Dim rngCell As Range
Dim intX As Integer
Dim intY As Integer
'iterate all cells in range
For intX = 1 To rng.Rows.Count
For intY = 1 To rng.Columns.Count
'get a cell
Set rngCell = rng.Cells(intX, intY)
'check if cell is blank or empty
If IsEmpty(rngCell.Value) Or rngCell.Value = "" Then
'skip the rest of the columns in this row and goto next row
Exit For
Else
'this row has non-empty cells - do something
Debug.Print rngCell.Address
'some other test
If rngCell.HasFormula And InStr(1, rngCell.Formula, "SUMIF") Then
'update formula...
Debug.Print rngCell.Formula
End If
End If
Next intY
Next intX
End Sub
Code line to execute:
Range("A1:A10").SpecialCells(xlCellTypeVisible).Value = "1"
'This line send 1 to Visible Cells in A1:A10 range