I need to protect some data using VBA in a worksheet but leave some cells open so that data can be entered - tab name "Part Order"
My data starts in A5 and goes through to J
I have a couple of issues which I am struggling to resolve - see below
If data is found in column A from cell 5 then lock (A to F) then (H) And Then all cells from (K) to the end of the worksheet
this leaves all cells unlocked in G5 down I5 down and J down
If data is not found in column A from cell 5 then lock the complete row
If anyone can help with this it would be most appreciated.
Thanks in advance
Try this one:
Sub LockCells()
Dim sLastColName As String
Dim lLastRow As Long
Dim i As Long
With Worksheets("Part Order")
sLastColName = Mid(.Cells(1, .Columns.Count).Address, 2, _
InStr(2, .Cells(1, .Columns.Count).Address, "$") - 2)
lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells.Locked = False
For i = 5 To lLastRow
If .Cells(i, "A").Value <> vbNullString Then
.Range("A" & i & ":F" & i & ",H" & i & ",K" & i & ":" & sLastColName & i).Locked = True
Else
.Rows(i).Locked = True
End If
Next i
End With
End Sub
Related
The following code is throwing an 1004 runtime error when I go to run. The debugger highlights the SUMIFS function in just above part 2.
The goal of this sub is to locate duplicate rows using columns 1, 3, and 5 as "primary-keys" and then combine values by column for rows 6-7 and 10-17 based off those values for each row. Hence the SUMIFS.
I'm confused. Using the immediate window I can return the correct values for each section of the SUMIFS fuction (ws.Cells(lRow, lCol).Select will select the correct cell, etc.). My next thought was that the ranges were not interpreted correctly by the SUMIFS so I popped the same function, using specific ranges, into the immediate window and received the same error. See line below for immediate window entry - note that the goal is to combine values between rows 21:23 in this example.
debug.Print application.WorksheetFunction.SumIfs(range("F21:F23"), range("A9:A30"), range("A21").Value, range("C9:C30"), range("C21").Value, range("E9:E30"), range("E21").Value)
I'm assuming, and 100% sure, that named ranges, .codenames, and variables are working as desired. That said, I've been mistaken before.
Any help would be greatly appreciated.
Private Sub dba_combine_rows()
Const COL_TRIPS = 6
Const COL_EMP_TRIP = 7
Const COL_LN_HC = 10
Const COL_USN_PR = 17
Dim lLastRow As Long
Dim ws As Worksheet
Set ws = DBA
Dim answer As Integer
answer = MsgBox("Are you sure you want to combine rows?", vbYesNo, "Combine Rows")
If answer = vbNo Then
Exit Sub
End If
'Get the last row
Dim i As Long
For i = Range("inputRange" & ws.CodeName).Column To (Range("inputRange" & ws.CodeName).Column + Range("inputRange" & ws.CodeName).Columns.Count - 1)
If ws.Cells(ws.Rows.Count, i).End(xlUp).Row > lLastRow Then
lLastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
End If
Next i
''Combine, start modify
'Set aliases for columns A & B & C, used for checking duplicates
Dim rngA As Range, rngB As Range, rngC As Range
Set rngA = ws.Range("inputRange" & ws.CodeName).Columns(1)
Set rngB = ws.Range("inputRange" & ws.CodeName).Columns(3)
Set rngC = ws.Range("inputRange" & ws.CodeName).Columns(5)
Dim lRow As Long, lCol As Long, strHolderA As String, lHolderR As Long
For lRow = ws.Range("inputRange" & ws.CodeName).Row To lLastRow
'Part 1 - Check for duplicate entity-country
If Application.CountIfs(rngA, ws.Cells(lRow, rngA.Column), rngB, ws.Cells(lRow, rngB.Column), rngC, ws.Cells(lRow, rngC.Column)) > 1 Then
strHolderA = (ws.Cells(lRow, rngA.Column).Value & ws.Cells(lRow, rngB.Column).Value & ws.Cells(lRow, rngC.Column).Value)
lHolderR = lRow
For lCol = COL_TRIPS To COL_USN_PR
If lCol = COL_EMP_TRIP Then
lCol = COL_LN_HC
End If
ws.Cells(lRow, lCol).Value = Application.WorksheetFunction.SumIfs( _
ws.Range(Col_Letter(lCol) & lRow & ":" & Col_Letter(lCol) & lLastRow), rngA, ws.Cells(lRow, rngA.Column).Value, rngB, ws.Cells(lRow, rngB.Column).Value, rngC, ws.Cells(lRow, rngC.Column).Value)
Next lCol
'Part 2 - Delete similar rows, excluding 1st
Dim lRow2 As Long
For lRow2 = ws.Range("inputRange" & ws.CodeName).Row To lLastRow
If (ws.Cells(lRow2, rngA.Column).Value & ws.Cells(lRow2, rngB.Column).Value & _
ws.Cells(lRow2, rngC.Column).Value) = strHolderA And lRow2 <> lHolderR Then
Rows(lRow2 & ":" & lRow2).Select
Selection.Delete Shift:=xlUp
lRow2 = lRow2 - 1
End If
Next lRow2
End If
Next lRow
End Sub
The sum_range parameter (the first one) has to be the same size as the criteria ranges, which all. also, have to be the same size.
"F21:F23" is just 3 cells, while the others i.e. "A9:A30" count 22 cells each.
I'm in dire need for code that will copy & paste newly extracted data into a tracking worksheet, based off of matching numbers in the first column.
I have two worksheets, "Registry" and "Sheet2". Registry is used for tracking, Sheet2 has new data I want to transfer into Registry.
I want the insurance type data (col B) from Sheet2 to be copied and pasted into the insurance type column in Registry (col E). But I need it to match up with the ID's in col A because my extraction doesn't include all ID's that I have listed in Registry.
If helpful, the range of cells w/ data in Registry is row2:row177; range of cells w/ data in Sheet2 is row2:row174
I appreciate all the help, let me know if I wasn't clear enough or if you need any more info.
Thanks,
Kyle
Sub updateins()
Dim i As Long
Dim j As Long
Sheet1LastRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Registry").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To Sheet1LastRow
For i = 2 To Sheet2LastRow
If Worksheets("Sheet2").Cells(j, 1).Value = Worksheets("Registry").Cells(i, 1).Value Then
Worksheets("Sheet2").Cells(j, 2).Value = Worksheets("Registry").Cells(i, 5).Value
Else
End If
Next i
Next j
End Sub
Not sure what the problem might be. The code is working fine for me. Here are just a few minor adjustments as proposed:
Option Explicit
Sub updateins()
Dim i As Long
Dim j As Long
Dim Sheet1LastRow As Long
Dim Sheet2LastRow As Long
Sheet1LastRow = Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Registry").Range("A" & Worksheets("Registry").Rows.Count).End(xlUp).Row
MsgBox "Comparing rows 2 through " & Sheet1LastRow & " on 'Sheet2'" & Chr(10) & _
"with rows 2 through " & Sheet2LastRow & " on 'Registry'."
For j = 2 To Sheet1LastRow
For i = 2 To Sheet2LastRow
If UCase(Trim(Worksheets("Sheet2").Cells(j, 1).Value)) = UCase(Trim(Worksheets("Registry").Cells(i, 1).Value)) Then
Worksheets("Registry").Cells(j, 5).Value = Worksheets("Sheet2").Cells(i, 2).Value
End If
Next i
Next j
End Sub
I merely added a MessageBox to make sure that both last rows are correctly determined through column A.
I want to make a macro that clears the content of the cells in the blue border (~40.000 Rows) when the cells in the red border (column AX) contain the text "NoBO" (=No Backorder) without losing the formulas in the columns AP:AX.
Sub clear_ranges()
Dim ws As Worksheet
Dim x As Integer
Dim clearRng As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Input")
For x = 6 To ws.Range("B" & Rows.Count).End(xlUp).Row
If (ws.Range("AX6" & x).Value = "NoBO") Then
If clearRng Is Nothing Then
Set clearRng = ws.Range("B6" & x & ":" & "AN6" & x)
Else
Set clearRng = Application.Union(clearRng, ws.Range("B6" & x & ":" & "AN6" & x))
End If
End If
Next x
clearRng.Clear
End Sub
And for some reason:
For x = 6 To ws.Range("B" & Rows.Count).End(xlUp).Row
gives me a error "Overflow". After searching I know what this error means but I can't find a solution for this.
tl;dr - I want to delete the range B6:B##### (till last row) to AN6:AN####*(till last row) if cell AX##### containts NoBO
It is too easy to get an overflow using Integer. Replace:
Dim x As Integer
with:
Dim x As Long
Try:
Sub clear_ranges()
Dim ws As Worksheet
Dim x As Integer
Dim clearRng As Range
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Input")
For x = 6 To ws.Range("B" & Rows.Count).End(xlUp).Row
If ws.Range("AX" & x).Value = "NoBO" Then
ws.Range("B" & x & ":" & "AN" & x).Clear
End If
Next x
Application.ScreenUpdating = True
End Sub
I think the Union function can only store up to 30 ranges so it might not suit your needs.
Hi if you are Deleting Rows it's the Best to use a For Each Loop or start from the bottom of the column and work up.
'Loop through cells A6:Axxx and delete cells that contain an "x."
For Each c In Range("AX6:A" & ws.Range("B" & Rows.Count).End(xlUp).Row)
If c.Value2 = "NoBo" Then
Set clearRng = ws.Range("B" & c.Row & ":" & "AN" & c.Row)
End If
clearRng.Clear
Next
try this
Option Explicit
Sub clear_ranges()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Input")
With ws
With .Range("B5:AX" & .Cells(.Rows.Count, "B").End(xlUp).Row) 'take all data
.AutoFilter Field:=49, Criteria1:="NoBO" 'filter to keep only rows with "NoBO" in column "AX" (which is the 49th column from column "B"
With .Offset(1).Resize(.Rows.Count - 1) 'offset from headers
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 0 Then Intersect(.SpecialCells(xlCellTypeVisible), ws.Columns("B:AN")).ClearContents 'clear cells in columns "B:AN" of filtered rows
End With
.AutoFilter 'remove autofilter
End With
End With
Application.ScreenUpdating = True
End Sub
You can try
Assuming that there are no blank cells in AX Column
Sub clr_cell()
For i = 6 To ActiveSheet.Range("AX6", ActiveSheet.Range("AX6").End(xlDown)).Rows.Count
'counts the no. of rows in AX and loops through all
If ActiveSheet.Cells(i, 50).Value = "NoBo" Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 40)).ClearContents
'clears range B to AN
End If
Next i
End Sub
I tested this on 40k rows and it worked fine. It takes a while to execute due to the no. of rows maybe.
Newbee here to both this site and Excel VBA. I used RichA's code in the below post and was able to make it work well for my purpose of populating/copying data in on sheet (Sheet2) from another sheet.
CODE LINK TO ORIGINAL POST
Excel VBA Copy and Paste Loop within Loop
I have a question on how to limit the range to a 'named range' (C13:Z111) rather than the 'entire column' ("C") in this code. I cannot seem to get it to limit to copy rows, starting with last row with data and counting down to the first row.
I have some rows (C1:C12) with titles at the top and the data starts at row 13. So when copying values from one sheet to the 'other' sheet, the top rows also copy. I would like to end the copying of data at row 13.
Thank you for your help.
Here is what currently works with the exception that I am not able to limit the range.
Sub Generate_Invoice()
Dim i As Long
Dim ii As Long
Dim i3 As Long
Dim LastRow As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("INCENTIVE")
Set sht2 = wb.Sheets("Sheet2")
Sheets("Sheet2").Select
Range("B11:Z200").ClearContents
'Find the last row (in column C) with data.
LastRow = sht1.Range("C13:C111").Find("*", searchdirection:=xlPrevious).Row
ii = 2
'This is the beginning of the loop >>>This Works BUT BUT BUT goes all the way to the top - REQUESTING HELP WITH CODE ENDS AT ROW 13 AND DOES NOT GO PAST<<<
For i = 3 To LastRow
'First activity
sht2.Range("B" & ii) = sht1.Range("C" & i).Value
sht2.Range("C" & ii) = sht1.Range("G" & i).Value
sht2.Range("D" & ii) = sht1.Range("H" & i).Value
sht2.Range("E" & ii) = sht1.Range("P" & i).Value
sht2.Range("F" & ii) = sht1.Range("R" & i).Value
sht2.Range("G" & ii) = sht1.Range("AD" & i).Value
ii = ii + 1
Next i
'Return to "Sheet2"
Sheets("Sheet2").Select
'Add SUM at bottom of last record in Range"D"
Dim ws As Worksheet
For Each ws In Worksheets
With ws.Range("F" & Rows.Count).End(xlUp).Offset(2)
.FormulaR1C1 = "=SUM(R11C6:R[-1]C6)"
.Offset(, -1).Value = "Total:"
End With
Next ws
End Sub
You were looking for the last row but only looking within the populated area. I would suggest changing the method that the last row is determined by starting at the bottom of the worksheet and finding the last populated cell in column C. This would be like being in C1048576 and tapping Ctrl+▲.
'Find the last row (in column C) with data.
LastRow = sht1.Cells(Rows.Count, "C").End(xlUp).Row
'not sure whether you want to reverse this as well
ii = 2
'This is the beginning of the loop >>>This Works BUT BUT BUT goes all the way to the top - REQUESTING HELP WITH CODE ENDS AT ROW 13 AND DOES NOT GO PAST<<<
For i = LastRow To 13 Step -1 'work from the bottom to the top.
'First activity
sht2.Range("B" & ii) = sht1.Range("C" & i).Value
sht2.Range("C" & ii) = sht1.Range("G" & i).Value
sht2.Range("D" & ii) = sht1.Range("H" & i).Value
sht2.Range("E" & ii) = sht1.Range("P" & i).Value
sht2.Range("F" & ii) = sht1.Range("R" & i).Value
sht2.Range("G" & ii) = sht1.Range("AD" & i).Value
'not sure whether you want to reverse this as well
ii = ii + 1
Next i
You just need to exit the for loop based on whatever your desired criteria is. For example:
If ii = 13 Then Exit For
I'm trying to add a Vlookup piece to a long macro that I'm working on to eliminate some daily data manipulation work.
Essentially everyday I have four new columns of data that I compare to the day befores, using vlookup. The four new columns sit in columns C-F and the old data in columns M-P. I vlookup column D against column M, with the formula in column G.
I'm running into a problem of how to be flexible with the range I give the macro to use each day as I don't want to constantly change it. The amount of rows will fluctuate between 10,000-30,000.
Here is my code- I'm probably thinking about this all wrong.
Sub Lookup()
Dim i, LastRow
Set i = Sheets("data").Range("F5").End(xlUp)
If Cells(i, "F5").Value <> "" Then
Range(i, "G").Value = WorksheetFunction.VLookup(Cells(i, "D"), Range("N").End(xlDown), 1, False)
End If
End Sub
Give this a go
Sub Sheet2_Button1_Click()
Dim Rws As Long, rng As Range, Mrng As Range, x
Rws = Cells(Rows.Count, "D").End(xlUp).Row
Set rng = Range(Cells(1, "G"), Cells(Rws, "G"))
Set Mrng = Range("M1:M" & Rws)
rng = "=IFERROR(VLOOKUP(D1, " & Mrng.Address & ",1,0),""Nope"")"
'----------If you want it to be just values uncomment the below line--------------
' rng.Value=rng.Value
End Sub
You have some backwards range references. I can't speak to the vlookup call, but you can start by looking at this part:
If Cells(i, "F5").Value <> "" Then
Range(i, "G").Value = WorksheetFunction.VLookup(Cells(i, "D"), Range("N").End(xlDown), 1, False)
End If
Try changing it to this to fix the range declarations:
If Range("F" & i).Value <> "" Then
Range("G" & i).Value = WorksheetFunction.VLookup(Range("D" & i), Range("N").End(xlDown), 1, False)
End If