I have written this below code to automate search function for a value T5536
which is in A1 cell of sheet1 and compare the A1 cell value with a column from sheet2 which has n number of values.
When the A1 value T5536 matches the value from Sheet2 A column then it should update the Sheet1 with Corresponding ES or IS values.
If the ES value in Sheet2 has Indirect word or string then it should update IS value in sheet1.
Please find the below code for the same :-
Sub test()
Dim lrow As Long
Dim i, j As Variant
Dim ms, ws As Worksheet
Dim num, esr, isr,x As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ms = Worksheets("sheet1")
Worksheets("Sheet2").Activate
ms.Cells(2, 3) = ""
ms.Cells(2, 2) = ""
Set ws = Worksheets("Sheet2")
num = WorksheetFunction.Match("number", Range("1:1"), 0)
esr = WorksheetFunction.Match("ES", Range("1:1"), 0)
isr = WorksheetFunction.Match("IS", Range("1:1"), 0)
x = sheet2.cells(sheet2.rows.count,"A").end(xlup).row
FoundRange = ms.Range("A1")
For i = 2 To x
If ws.Cells(i, num) = FoundRange Then
Worksheets("sheet1").Activate
ms.Cells(2, 3) = ws.Cells(i, isr)
If ws.Cells(i, es) = "indirect" Then
ms.Cells(2, 2) = ws.Cells(i, is)
Else
ms.Cells(2, 2) = ws.Cells(i, es)
End If
End If
If ms.Cells(2, 2) <> "" Then
Exit For
End If
Next i
End Sub
The following code will work and takes less time when there are only few values to match in sheet2 A column, but if there are n number of values in sheet2 then it will be difficult to go through for loop and fulfil the task, kindly help me in tweaking this code to search the value very fast and update the corresponding values.
I have attached the images which might help to analyse the query.
Check it out. You can edit this code as you require.
Sub loopExample()
Dim sh As Worksheet, ws As Worksheet
Dim LstRw As Long, Frng As Range
Dim rng As Range, c As Range, x
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
Set Frng = sh.Range("A1")
With ws
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & LstRw)
End With
For Each c In rng.Cells
If c = Frng Then
x = IIf(c.Offset(0, 1) = "indirect", 2, 1)
sh.Range("B2") = c.Offset(0, x)
End If
Next c
End Sub
Related
I want to screen all sheets for values that starts with "D"
In the sheets I formed blocks (1 column, 4 rows) with
- owner
- area
- parcel (that is allways starting with a "D")
- year of transaction (blocks of 1 column and 4 rows).
I want to make a summary in sheet "Test".
I'm able to find the parcel, but how can I get the info from the cell above?
Sub Zoek_kavels()
Dim ws As Worksheet
Dim rng As Range
Dim Area
Dim Kavel As String
rij = 1
For Each ws In ActiveWorkbook.Sheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell.Value, 1) = "D" Then 'Starts with D
Sheets("Test").Cells(rij, 1) = cell.Value 'Kavel D..
Cells(cell.row - 1, cell.Column).Select
Area = ActiveCell.Value
Sheets("Test").Cells(rij, 2) = Area 'Oppervlakte
Sheets("Test").Cells(rij, 3) = ws.Name 'Werkblad naam
rij = rij + 1
End If
Next
Next
End Sub
A nice simple loop should do the trick, you may have had spaces in the worksheet, that would throw off the used range.
Here is a different approach.
Sub Get_CellAboveD()
Dim LstRw As Long, sh As Worksheet, rng As Range, c As Range, ws As Worksheet, r As Long
Set ws = Sheets("Test")
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:A" & LstRw)
If LstRw > 1 Then
For Each c In rng.Cells
If Left(c, 1) = "D" Then
r = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
ws.Range("A" & r).Value = c
ws.Range("B" & r).Value = c.Offset(-1).Value
ws.Range("C" & r).Value = sh.Name
End If
Next c
End If
End With
End If
Next sh
End Sub
There are two important points (and two not so important) to take care of your code:
start from row 2, because you are using .row - 1. Thus, if you start at row 1, row-1 would throw an error;
try to avoid Select, ActiveCell, etc.;(How to avoid using Select in Excel VBA);
write comments in English, not in Dutch (also good idea for variable names as well, rij or kavel do not help a lot);
declare the type of your variables, e.g. dim Area as String or as Long or anything else;
Option Explicit
Sub ZoekKavels()
Dim ws As Worksheet
Dim rng As Range
Dim Kavel As String
Dim rij As Long
Dim cell As Range
rij = 2 'start from the second row to avoid errors in .Row-1
For Each ws In ActiveWorkbook.Worksheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell, 1) = "D" Then
With Worksheets("Test")
.Cells(rij, 1) = cell
.Cells(rij, 2) = ws.Cells(cell.Row - 1, cell.Column)
.Cells(rij, 3) = ws.Name
End With
rij = rij + 1
End If
Next
Next
End Sub
Or you can use .Cells(rij, 2) = cell.Offset(-1, 0) instead of Cells(cell.Row - 1, cell.Column), as proposed in the comments by #Shai Rado.
I have written a macro to remove rows containing certain text in it. If either of the keyword contains any text, the macro will delete the row. However, the macro doesn't work at all. Perhaps, i did something wrong in it. Hope somebody will help me rectify this. Thanks in advance.
Here is what I'm trying with:
Sub customized_row_removal()
Dim i As Long
i = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Cells(i, 1).Select
Selection.EntireRow.Delete
End If
i = i + 1
Loop
End Sub
The keyword within the text I was searching in to delete:
AIRLINE DRIVE OWNER mth
A rtd REPAIRS INC
AANA MICHAEL B ET AL
ABASS OLADOKUN
ABBOTT npt P
AIRLINE AANA MTH
ABASS REPAIRS NPT
Try like this.
What about Using Lcase.
Sub customized_row_removal()
Dim rngDB As Range, rngU As Range, rng As Range
Dim Ws As Worksheet
Set Ws = Sheets(1)
With Ws
Set rngDB = .Range("a2", .Range("a" & Rows.Count))
End With
For Each rng In rngDB
If InStr(LCase(rng), "mth") Or InStr(LCase(rng), "rtd") Or InStr(LCase(rng), "npt") Then
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End If
Next rng
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
End Sub
VBA syntax of your Or is wrong,
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Should be:
If Cells(i, 1).Value = "mth" Or Cells(i, 1).Value = "rtd" Or Cells(i, 1).Value = "npt" Then
However, you need to use a string function, like Instr or Like to see if a certain string is found within a longer string.
Code
Option Explicit
Sub customized_row_removal()
Dim WordsArr As Variant
Dim WordsEl As Variant
Dim i As Long, LastRow As Long
Dim Sht As Worksheet
WordsArr = Array("mth", "rtd", "npt")
Set Sht = Worksheets("Sheet1")
With Sht
' get last row in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 2 Step -1
For Each WordsEl In WordsArr
If LCase(.Cells(i, 1).Value) Like "*" & WordsEl & "*" Then
.Rows(i).Delete
End If
Next WordsEl
Next i
End With
End Sub
I try to make my code sample as I can if you have any question please ask
Private Sub remove_word_raw()
'PURPOSE: Clear out all cells that contain a specific word/phrase
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
'What range do you want to search?
Set Rng = Range("A2:A25")
'sub for the word
shorttext1 = "mth"
shorttext2 = "rtd"
shorttext3 = "npt"
'What phrase do you want to test for?
ContainWord1 = shorttext1
ContainWord2 = shorttext2
ContainWord3 = shorttext3
'Loop through each cell in range and test cell contents
For Each cell In Rng.Cells
If cell.Value2 = ContainWord1 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord2 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord3 Then cell.EntireRow.Delete
Next cell
End Sub
I'm trying to compare cell values between 2 Sheets (Sheet1 & Sheet2) to see if they match, and if they match move the matching values in Sheet1 to a pre-existing list (Sheet3) and delete the values in Sheet1 afterwards.
I'm using the reverse For Loop in Excel VBA, but everything works until the part where I start deleting the row using newrange1.EntireRow.Delete.
This throws a '424' Object Required Error in VBA and I've spent hours trying to solve this, I'm not sure why this is appearing. Am I selecting the row incorrectly? The object?
Would appreciate if anyone can point me to the correct direction.
Here's my code:
Sub Step2()
Sheets("Sheet1").Activate
Dim counter As Long, unsubListCount As Long, z As Long, x As Long, startRow As Long
counter = 0
startRow = 2
z = 0
x = 0
' Count Sheet3 Entries
unsubListCount = Worksheets("Sheet3").UsedRange.Rows.Count
Dim rng1 As Range, rng2 As Range, cell1 As Range, cell2 As Range, newrange1 As Range
' Select all emails in Sheet1 and Sheet2 (exclude first row)
Set rng1 = Worksheets("Sheet1").Range("D1:D" & Worksheets("Sheet1").UsedRange.Rows.Count)
Set rng2 = Worksheets("Sheet2").Range("D1:D" & Worksheets("Sheet2").UsedRange.Rows.Count)
' Brute Loop through each Sheet1 row to check with Sheet2
For z = rng1.Count To startRow Step -1
'Cells(z, 4)
Set cell1 = Worksheets("Sheet1").Cells(z, "D")
For x = rng2.Count To startRow Step -1
Set cell2 = Worksheets("Sheet2").Cells(x, "D")
If cell1.Value = cell2.Value Then ' If rng1 and rng2 emails match
counter = counter + 1
Set newrange1 = Worksheets("Sheet1").Rows(cell1.Row)
newrange1.Copy Destination:=Worksheets("Sheet3").Range("A" & unsubListCount + counter)
newrange1.EntireRow.Delete
End If
Next
Next
End Sub
Here's the error I'm getting:
Your inner loop produces a lot of step-by-step work that is better accomplished with Application.Match. Your use of .UsedRange to retrieve the extents of the values in the D columns is better by looking for the last value from the bottom up.
Option Explicit
Sub Step2()
Dim z As Long, startRow As Long
Dim rng2 As Range, wk3 As Worksheet, chk As Variant
startRow = 2
z = 0
Set wk3 = Worksheets("Sheet3")
' Select all emails in Sheet1 and Sheet2 (exclude first row)
With Worksheets("Sheet2")
Set rng2 = .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp))
End With
With Worksheets("Sheet1")
For z = .Cells(.Rows.Count, "D").End(xlUp).Row To startRow Step -1
chk = Application.Match(.Cells(z, "D").Value2, rng2, 0)
If Not IsError(chk) Then
.Cells(z, "A").EntireRow.Copy _
Destination:=wk3.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Cells(z, "A").EntireRow.Delete
End If
Next
End With
End Sub
As noted by Ryan Wildry, your original problem was continuing the loop and comparing after deleting the row. This can be avoided by adding Exit For after newrange1.EntireRow.Delete to jump out of the inner loop once a match was found. I don't think you should 'reset cell1' as this may foul up the loop iteration.
I think what's happening is when you are deleting the row, you are losing the reference to the range Cell1. So I reset this after the deletion is done, and removed the reference to newRange1. Give this a shot, I have it working on my end. I also formatted the code slightly too.
Option Explicit
Sub Testing()
Dim counter As Long: counter = 0
Dim z As Long: z = 0
Dim x As Long: x = 0
Dim startRow As Long: startRow = 2
Dim Sheet1 As Worksheet: Set Sheet1 = ThisWorkbook.Sheets("Sheet1")
Dim Sheet2 As Worksheet: Set Sheet2 = ThisWorkbook.Sheets("Sheet2")
Dim Sheet3 As Worksheet: Set Sheet3 = ThisWorkbook.Sheets("Sheet3")
Dim rng1 As Range: Set rng1 = Sheet1.Range("D1:D" & Sheet1.UsedRange.Rows.Count)
Dim rng2 As Range: Set rng2 = Sheet2.Range("D1:D" & Sheet2.UsedRange.Rows.Count)
Dim unsubListCount As Long: unsubListCount = Sheet3.UsedRange.Rows.Count
Dim cell1 As Range
Dim cell2 As Range
Dim newrange1 As Range
' Brute Loop through each Sheet1 row to check with Sheet2
For z = rng1.Count To startRow Step -1
Set cell1 = Sheet1.Cells(z, 4)
For x = rng2.Count To startRow Step -1
Set cell2 = Sheet2.Cells(x, 4)
If cell1 = cell2 Then
counter = counter + 1
Set newrange1 = Sheet1.Rows(cell1.Row)
newrange1.Copy Destination:=Sheet3.Range("A" & unsubListCount + counter)
newrange1.EntireRow.Delete
Set newrange1 = Nothing
Set cell1 = Sheet1.Cells(z, 4)
End If
Next
Next
End Sub
I need some advice.
my code Check the cell "E" in sheet "Total" with the cell "B" in sheet "lists", if the values are equal it reads the cell "A" in the sheet "list" (which contains the name of all my sheets), and copies the match line in the correct sheet.
My script works but is very slow. Do you have any advice on how to speed up the process?
Currently the script read and copy line by line, I thought to speed up the process by applying automatic filter but do not know where to start ...
Thanks in advance.
This is my actual script:
Sub copystatus()
Dim LR As Long
Dim LC As Integer
Dim LB As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim cLista As String
Set ws = ThisWorkbook.sheets("totale")
Set ws2 = ThisWorkbook.sheets("liste")
LR = ws.Cells(Rows.Count, 5).End(xlUp).Row
LC = ws2.Cells(Rows.Count, 2).End(xlUp).Row
With ws
For x = 2 To LR
For i = 2 To LC
If .Cells(x, 5).value = ws2.Cells(i, 2).value Then
cLista = ws2.Cells(i, 1).value
Set ws3 = ThisWorkbook.sheets(cLista)
On Error GoTo ErrorHandler
LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws3.Rows(LB + 1).value = .Rows(x).value
ws3.Rows(1).value = .Rows(1).value
End If
Next i
Next x
End With
ErrorHandler:
End Sub
Check this out - the increase should be visible:
Sub copystatus()
Dim LR As Long
Dim LC As Integer
Dim LB As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim cLista As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Set ws = ThisWorkbook.sheets("totale")
Set ws2 = ThisWorkbook.sheets("liste")
LR = ws.Cells(Rows.Count, 5).End(xlUp).Row
LC = ws2.Cells(Rows.Count, 2).End(xlUp).Row
With ws
For x = 2 To LR
For i = 2 To LC
If .Cells(x, 5).value = ws2.Cells(i, 2).value Then
cLista = ws2.Cells(i, 1).value
Set ws3 = ThisWorkbook.sheets(cLista)
On Error GoTo ErrorHandler
LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws3.Rows(LB + 1).value = .Rows(x).value
ws3.Rows(1).value = .Rows(1).value
End If
Next i
Next x
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
ErrorHandler:
End Sub
And at the end set the ws, ws2, ws3 to Nothing like this:
Set ws = nothing
set ws2 = nothing
Something like this, starting with a 2 column data set
Sub ARRAY_WAY()
Dim arrSource() As Variant
Dim arrCheck() As Variant
Dim intArrayLoop As Integer
Dim intArrayLoop2 As Integer
arrSource = Range("A1:B7").Value
arrCheck = Range("C1:D3").Value
For intArrayLoop = 1 To UBound(arrSource)
For intArrayLoop2 = 1 To UBound(arrCheck)
If arrCheck(intArrayLoop2, 1) = arrSource(intArrayLoop, 1) Then
arrCheck(intArrayLoop2, 2) = arrSource(intArrayLoop, 2)
Exit For
End If
Next intArrayLoop2
Next intArrayLoop
Range("c1:d3").Value = arrCheck
End Sub
Will give an output like this (Columns C to D)
I assume that is another follow-up macro for your recent question?
As you already check for that condition and generate your worksheets there (cLista) it would be better off to copy the rows there in the first place.
With screen updating disabled as suggested by Vityata this should be running OK.
You can try and simplify this part:
Set ws3 = ThisWorkbook.sheets(cLista)
On Error GoTo ErrorHandler
LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws3.Rows(LB + 1).value = .Rows(x).value
ws3.Rows(1).value = .Rows(1).value
You might be better off without using set for ws3 and just simply refer to your target in one line instead of doins multiple variable assignment
sheets(clista).Rows(sheets(clista).Cells(Rows.Count, 1).End(xlUp).Row +1).value = .Rows(x)value
sheets(clista).Rows(1).value = .Rows(1)value
I've been working with some code that opens a workbook and finds values based off a reference cell. It searches for a string and takes the cell next to it. unfortunately i now have 2 cells in the workbook that 'contain' the reference string. one cells is "Current Score" the other is "Percentage of Current Score". Is there a way to state that I just want "Current Score" and nothing else in the cell.
Sorry if this is a tad wordy, I can provide the code if necessary
EDIT: Here is the code:
Sub Future_Score()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
ReDim findValues(1 To 3)
findValues(1) = "Curren" & "*" & "Core"
findValues(2) = "dummyvariable1"
findValues(3) = "dummyvariable2"
counter = 0
r = Range("A163").End(xlDown).Row
Set rng = Range(Cells(163, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
'For Each sht In Wrbk.Worksheets
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 1).Value
secondAddress = c.Offset(0, 3).Value
thirdAddress = c.Offset(0, 4).Value
Do
This.Activate
tmp.Offset(0, 4).Value = firstAddress
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
'Wrbk.Activate
'Next sht
Wrbk.Close
Next tmp
End Sub
Have played around with the code a bit. The dummy variables will be in use for other functions, but basically the gist is to open a workbook, find a cell, take the cell next to it, paste in the original workbook. The problem is it picks up multiple cells that contain a string. I have used "Curren" & "Core" as the macro doesn't seem to handle spaces in strings to well.
Change
Set c = .Find(findValues(i), LookIn:=xlValues)
to
Set c = .Find(findValues(i), LookIn:=xlValues, LookAt:=xlWhole)
to require that the entire cell match the search string, rather than just part of the cell.