I use the below code to color the cells in column K and Z that match the criteria; but it colors all cells between K and Z. To fix, I use the last line of code to remove the color in columns L thru Y. Is there a way to modify the line of code that starts with "Range" to only color cells K and Z that match the criteria?
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
End If
Next i
Columns("L:Y").Interior.ColorIndex = xlNone
End With
End Sub
You are specifying the Range.Parent property in your With ... End With statement but ignoring it when it is most important¹.
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
.Range("K" & i & ", Z" & i).Interior.ColorIndex = 6
Else
.Range("K" & i & ", Z" & i).Interior.Pattern = xlNone
End If
Next i
End With
End Sub
A Range object to Union discontiguous cells could be one of the following.
.Range("K5, Z5")
Union(.Cells(5, "K"), .Cells(5, "Z"))
In the example above, I've concatenated together a string like the first of these two examples.
¹ See Is the . in .Range necessary when defined by .Cells? for an earnest discussion on this subject.
You could replace
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
with
.Cells(i, 11).Interior.ColorIndex = 6
.Cells(i, 26).Interior.ColorIndex = 6
Related
Basically, if in Sheet1 the cell in Column I is Not Blank, copy cells A, B, I and L to Sheet 2 on the next available blank row. Loop until end of rows on Sheet1.
I keep getting an error 9 or 450 code at the .Copy line.
I have connected the Module to a button on Sheet2. Could this be the reason?
Or should I use something different from the CopyPaste function?
This is the code I've been trying to get to work.
Option Explicit
Sub copyPositiveNotesData()
Dim erow As Long, lastrow As Long, i As Long
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheet1.Cells(i, "I") <> "" Then
Worksheets("Sheet1").Activate
' *** next line gives Err#450 "Wrong # of arguments or invalid property assignments" ****
Worksheets("Sheet1").Range(Cells(i, "A"), Cells(i, "B"), _
Cells(i, "I"), Cells(i, "L")).Copy
Worksheets("Sheet2").Activate
erow = WorkSheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2"). _
Range(Cells(i, "A"), Cells(i, "B"), Cells(i, "C"), Cells(i, "D"))
Worksheets("sheet1").Activate
End If
Next i
Application.CutCopyMode = False
End Sub
You need to use Application.Union to merge 4 cells in a row, something like the code below:
Full Modified Code
Option Explicit
Sub copyPositiveNotesData()
Dim erow As Long, lastrow As Long, i As Long
Dim RngCopy As Range
With Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Trim(.Cells(i, "I").Value) <> "" Then
Set RngCopy = Application.Union(.Range("A" & i), .Range("B" & i), .Range("I" & i), .Range("L" & i))
RngCopy.Copy ' copy the Union range
' get next empty row in "Sheet2"
erow = Worksheets("Sheet2").Cells(Worksheets("Sheet2").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' paste in the next empty row
Worksheets("Sheet2").Range("A" & erow).PasteSpecial xlPasteAll
End If
Next i
End With
Application.CutCopyMode = False
End Sub
You may try this (Not tested)
Option Explicit
Sub copyPositiveNotesData()
Intersect (Sheet1.Range("I2", Sheet1.Cells(.Rows.Count, "I").End(xlUp)).SpeciallCells(xlCellTypeConstants).EntireRow, Sheet1.Range("A:A", "B:B", "I:I", "L:L")).Copy Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub
Looks like the issue is that you are trying to copy multiple cells at once which isn't supported (try doing the same manually within the actual sheet). You need to copy either a single cell or a continuous range. You could either do 4 copy/pastes or could directly set the values in the destination sheet.
Try changing the copy/paste to the following (untested):
Sub copyPositiveNotesData()
Dim erow As Long, lastrow As Long, i As Long, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheet1.Cells(i, "I") <> "" Then
With ws2
.Range("A" & i).Value = ws1.Range("A" & i).Value
.Range("B" & i).Value = ws1.Range("B" & i).Value
.Range("I" & i).Value = ws1.Range("I" & i).Value
.Range("L" & i).Value = ws1.Range("L" & i).Value
End With
End If
Next i
End Sub
I want to delete entire row when all 3 numeric values in cells in columns G,H,I are equal. I wrote a vba code and it does not delete nothing. can Someone advise?
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
Set rng = Range("G2", Range("G2").End(xlDown))
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = 2 To NumRows
Cells(i, 7).Select
If Cells(i, 7).Value = Cells(i, 8).Value = Cells(i, 9).Value Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next i
End Sub
Try this code. When deleting rows, always start from last row and work towards first one. That way you are sure you wont skip any row.
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = NumRows + 1 To 2 Step -1
If Cells(i, 7).Value = Cells(i, 8).Value And Cells(i, 7).Value = Cells(i, 9).Value Then
Cells(i, 7).EntireRow.Delete
Else
End If
Next i
End Sub
Remember when you delete rows, all you need to loop in reverse order.
Please give this a try...
Sub remove_dup()
Dim NumRows As Long
Dim i As Long
NumRows = Cells(Rows.Count, "G").End(xlUp).Row
For i = NumRows To 2 Step -1
If Application.CountIf(Range(Cells(i, 7), Cells(i, 9)), Cells(i, 7)) = 3 Then
Rows(i).Delete
End If
Next i
End Sub
You can delete all rows together using UNION. Try this
Sub remove_dup()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim cel As Range, rng As Range
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 'last row with data in Column G
For i = lastRow To 2 Step -1 'loop from bottom to top
If .Range("G" & i).Value = .Range("H" & i).Value And .Range("G" & i).Value = .Range("I" & i).Value Then
If rng Is Nothing Then 'put cell in a range
Set rng = .Range("G" & i)
Else
Set rng = Union(rng, .Range("G" & i))
End If
End If
Next i
End With
rng.EntireRow.Delete 'delete all rows together
End Sub
I have a sheet with two columns. Column (E) contains ID and names from the data source and column (K) contains ID,which are extracted from comment section.
Column E contains sometime ID, starting with B2C, and sometime names and Id starting with 5. column K contains always ID starting with B2C. the length of the ID B2C is usually 11 to 13 Digit Long. the length of ID starting with 5 is 8 Digit Long.
I would like to have a VBA that checks both the columns, if there is an id starting with 5 or some Name in column E, then it should look into column K, if an ID starting with B2C is present, then it should copy to Column L, else copy the same value(from column E) to column L.
I researched through find and replace. I saw examples where exact Name of find was given and replaced with given Name. I am able to form an algorithm, but struck how to start with code in my case. the code below, has an runn time error
object varaible or with block variable not set .
Sub compare()
Dim i As Long
Dim ws As Worksheet
ws = Sheets("Sheet1")
For i = 1 To Rows.Count
If ws.Cells(i, 11).Value = "" Then
ws.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
ws.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next i
End Sub
I have an Image below, which Shows the end result.
Any lead would be appreciated.
The issue causing the error message is that you are missing a Set statement for your worksheet object. You must use Set when assigning an object to a variable, that is anything with its own methods. A simple data type without methods (String, Integer, Long, Boolean, ...) doesn't need the Set statement, and can just be directly assigned like i = 0.
Your code should be updated to:
Dim i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
' RED FLAG! Rows.Count is going to cause you to loop through the entire column,
' see the below example for how to use the UsedRange property.
For i = 1 To Rows.Count
If ws.Cells(i, 11).Value = "" Then
ws.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
ws.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next I
An alternative which avoids even using a worksheet variable would be to use a With block:
Dim r As Long
With ThisWorkbook.Sheets("Sheet1")
For r = 2 To .UsedRange.Rows.Count
.Range("L" & r).Value = .Range("E" & r).Value
If .Range("K" & r).Value = "" Then .Range("L" & r).Value = .Range("K" & r).Value
Next r
End With
Edit:
There are various ways to find the last used row, each with their drawbacks. A drawback of both UsedRange and xlCellTypeLastCell is they are only reset when you save/close/re-open the workbook. A better solution can be found in this answer.
Sub compare()
Dim r As Long, lastrow As Long, ws As WorkSheet
Set ws = ThisWorkbook.Sheets("Sheet1")
lastrow = LastRowNum(ws)
With ws
For r = 2 To lastrow
.Range("L" & r).Value = .Range("E" & r).Value
If .Range("K" & r).Value = "" Then .Range("L" & r).Value = .Range("K" & r).Value
Next r
End With
End Sub
' Function from linked question
Public Function LastRowNum(Sheet As Worksheet) As Long
LastRowNum = 1
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastRowNum = Sheet.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
This is my solution:
Option Explicit
Sub Compare()
Dim i As Long
Dim lngLastRow As Long
Dim ws As Worksheet
lngLastRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
Set ws = Worksheets(1)
With ws
.Columns(12).Clear
.Cells(1, 12) = "Extract from Comment"
For i = 1 To lngLastRow
If .Cells(i, 11).Value = "" Then
.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next i
End With
End Sub
It clears column(12) and writes Extract from comment in the first cell of the row, to make sure that everything is clean.
lngLastRow is the last row of the sheet.
I am trying to write a vba script that will filter on two columns, column A and column D. Preferably, I want to create a button that will execute once I have chosen the filter criteria. Sample of input data below.
Sub Compiler()
Dim i
Dim LastRow As Integer
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet4").Range("A2:J6768").ClearContents
For i = 2 To LastRow
If Sheets("Sheet1").Cells(i, "A").Values = Sheets("Sheet3").Cells(3, "B").Values And Sheets("Sheet1").Cells(i, "D").Values = Sheets("Sheet3").Cells(3, "D").Values Then
Sheets("Sheet1").Cells(i, "A" & "D").EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" + Rows.Count).End(xlUp)
End If
Next i
End Sub
Sample Data to run vba script
I have included my previous answer's changes into the full code block that is now provided below.
Sub Compiler()
Dim i
Dim LastRow, Pasterow As Integer
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("Sheet4")
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet4").Range("A2:J6768").ClearContents
For i = 2 To LastRow
If Sheets("Sheet1").Range("A" & i).Value = Sheets("Sheet3").Range("B3").Value And Sheets("Sheet1").Range("D" & i).Value = Sheets("Sheet3").Range("D3").Value Then
Pasterow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
Sheets("Sheet1").Rows(i).EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" & Pasterow)
End If
Next i
Sheets("sheet4").Rows(1).Delete
End Sub
Sheets("Sheet1").Cells(i, "A").Values
Sheets("Sheet3").Cells(3, "B").Values
etc
You keep using values. Don't you mean value?
This answered the question I was asking, I tried to work with Dan's answer but didn't get very far.
Private Sub CommandButton1_Click()
FinalRow = Sheets("Sheet1").Cells(rows.Count, 1).End(xlUp).Row
Sheets("Sheet4").Range(Sheets("Sheet4").Cells(1, "A"), Sheets("Sheet4").Cells(FinalRow, "K")).ClearContents
If Sheets("Sheet4").Cells(1, "A").Value = "" Then
Sheets("Sheet1").Range("A1:K1").Copy
Sheets("Sheet4").Range(Sheets("Sheet4").Cells(1, "A"), Sheets("Sheet4").Cells(1, "K")).PasteSpecial (xlPasteValues)
End If
For x = 2 To FinalRow
ThisValue = Sheets("Sheet1").Cells(x, "A").Value
ThatValue = Sheets("Sheet1").Cells(x, "D").Value
If ThisValue = Sheets("Sheet3").Cells(3, "B").Value And ThatValue = Sheets("Sheet3").Cells(3, "D").Value Then
Sheets("Sheet1").Range(Sheets("Sheet1").Cells(x, 1), Sheets("Sheet1").Cells(x, 11)).Copy
Sheets("Sheet4").Select
NextRow = Sheets("Sheet4").Cells(rows.Count, 1).End(xlUp).Row + 1
With Sheets("Sheet4").Range(Sheets("Sheet4").Cells(NextRow, 1), Sheets("Sheet4").Cells(NextRow, 11))
.PasteSpecial (xlPasteFormats)
.PasteSpecial (xlPasteValues)
End With
End If
Next x
Worksheets("Sheet4").Cells.EntireColumn.AutoFit
End Sub
I'm using this script to insert fill with rows where non-sequential is produced in a column of an excel file.
Sub InsertValueBetween()
Dim lastrow As Long
Dim gap As Long
Dim i As Long, ii As Long
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastrow To 3 Step -1
gap = .Cells(i, "A").Value - .Cells(i - 1, "A").Value
If gap > 1 Then
.Rows(i).Resize(gap - 1).Insert
End If
Next i
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(3, "A").Value = .Cells(2, "A").Value + 1
.Cells(2, "A").Resize(2).AutoFill .Cells(2, "A").Resize(lastrow - 1)
End With
End Sub
In addition to adding these new rows I want them to also have a specific value in column B. I'm trying to implement this but with no result.
Anybody could help me?
One way you could tackle this challenge is with a Range variable. Here is some heavily-commented code that walks through the process:
Sub InsertValueBetweenRev2()
Dim Target As Range '<~ declare the range variable
'... declare your other variables
'... do other stuff
For i = lastrow To 3 Step -1
gap = .Cells(i, "A").Value - .Cells(i - 1, "A").Value
If gap > 1 Then
.Rows(i).Resize(gap - 1).Insert
'the next line sets the range variable to the recently
'added cells in column B
Set Target = .Range(.Cells(i, 2), .Cells(i + gap - 2, 2))
Target.Value = "Cool" '<~ this line writes text "Cool" into those cells
End If
Next i
'... the rest of your code
End Sub
So, to sum it up, we know that gap - 1 rows are going to be added, and we know that the new rows are added starting at row i. Using that knowledge, we assign the just-added cells in column B to a Range then set the .value of that Range to whatever is needed.
a Better way of doing it with less variables and faster:
Sub InsRowWithText()
Dim LR As Long, i As Long
LR = Range("D" & Rows.Count).End(xlUp).row
For i = LR To 3 Step -1
If Range("D" & i).Value <> Range("D" & i - 1).Value Then
Rows(i).Resize(1).Insert
Range("D" & i).Value = "Test"
End If
Next i
End Sub
This is how i utilized it:
Sub InsRowWithText()
Dim strMsg As String, strTitle As String
Dim LR As Long, i As Long
Text = "ADD"
strMsg = "Warning: This is a Advanced Function, Continue? "
strTitle = "Warning: Activated Advanced Function "
If MsgBox(strMsg, vbQuestion + vbYesNo, strTitle) = vbNo Then
Exit Sub
Else
Sheets("SAP Output DATA").Select
If Range("D3").Value = Text Then
MsgBox "Detected That This Step Was Already Completed, Exiting."
Exit Sub
End If
application.ScreenUpdating = False
LR = Range("D" & Rows.Count).End(xlUp).row
For i = LR To 3 Step -1
If Range("D" & i).Value <> Range("D" & i - 1).Value Then
Rows(i).Resize(1).Insert
Range("D" & i).EntireRow.Interior.ColorIndex = xlColorIndexNone
Range(("A" & i), ("D" & i)).Value = Text
End If
Next i
End If
Range("D2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1).Select
Range(("A" & ActiveCell.row), ("D" & ActiveCell.row)).Value = Text 'last row doesnt get text for some reason.
ActiveCell.EntireRow.Interior.ColorIndex = xlColorIndexNone
ActiveCell.Offset(1).Select
Range(("D" & ActiveCell.row), ("E" & ActiveCell.row)).Interior.ColorIndex = 17 'purple
application.ScreenUpdating = True
Range("D3").Select
End Sub