I'm trying to search Column A in Sheet2 for the value of A1 in Sheet1.
If it exists, I'd like to delete the whole row in Sheet2.
If it doesn't exist, I'd like the message box to open.
Here's what I have, but I'm struggling with actually deleting the row:
Sub Delete_Rows()
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Sheet1").Range("A1")
If Trim(FindString) <> "" Then
With Sheets("Sheet2").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
'I can't figure out how to delete the row
Else
MsgBox "Not Found"
End If
End With
End If
End Sub
Here is an example based on THIS
You don't need to loop. You can use .Autofilter which is faster than looping.
Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim delRange As Range
Dim lRow As Long
Dim strSearch As String
Set ws1 = Sheet1: Set ws2 = Sheet2
strSearch = ws1.Range("A1").Value
With ws2
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=" & strSearch
Set delRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
If delRange Is Nothing Then
MsgBox "Not Found"
Else
delRange.Delete
End If
End Sub
Here is the code to :
loop through all the values in Column A of Sheet1,
look for all matches (with FindNext method) in Column A of Sheet 2
and delete the rows that matches
Give it a try :
Sub test_user5472539()
Dim Ws1 As Worksheet, _
Ws2 As Worksheet, _
LastRow As Long, _
FindString As String, _
FirstAddress As String, _
cF As Range
Set Ws1 = ActiveWorkbook.Sheets("Sheet1")
Set Ws2 = ActiveWorkbook.Sheets("Sheet2")
LastRow = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row
For i = 1 To LastRow
FindString = Ws1.Range("A" & i)
If Trim(FindString) <> "" Then
Ws2.Range("A1").Activate
With Ws2.Range("A:A")
'First, define properly the Find method
Set cF = .Find(What:=FindString, _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
'If there is a result, keep looking with FindNext method
If Not cF Is Nothing Then
FirstAddress = cF.Address
Do
cF.EntireRow.Delete
Set cF = .FindNext(cF)
'Look until you find again the first result
Loop While Not cF Is Nothing And cF.Address <> FirstAddress
Else
MsgBox "Not Found"
End If
End With
Else
End If
Next i
End Sub
Related
I am facing some issues with VBA. Let me explain what I am trying to achieve. I have 2 sheets in 1 workbook. They are labelled "Sheet1" and "Sheet2."
In "Sheet1," there are 100 rows and 100 columns. In column A, it is filled with eg: SUBJ001 all the way to SUBJ100. In "Sheet2," there is only 1 Column A, with a range of rows. Eg: "SUBJ003, SUBJ033, SUBJ45." What I am trying to achieve is to use my mouse, highlight the column A in "Sheet2," and compare each individual cell with the cells in column A. Should there be a match, it will copy the entire row and paste them in a new sheet that the macro creates in the same workbook. However, i am experiencing an out of range error at Set Rng =.Find(What:=Arr(I), ... Thanks!
Sub Copy_To_Another_Sheet_1()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Dim NewSh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Rng = Application.InputBox("Select target range with the mouse", Type:=8)
MyArr = Rng
Set NewSh = Worksheets.Add
With Sheets("Sheet1").Range("A:A")
Rcount = 0
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
Rng.EntireRow.Copy NewSh.Range("A" & Rcount)
' Use this if you only want to copy the value
' NewSh.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
MyArr = Rng is setting MyArr to be a two-dimensional array where the first rank corresponds to the rows in Rng and the second rank corresponds to the columns in Rng.
Assuming you only have one column in Rng, then your Find statement should refer to the values in that first column using MyArr(I, 1), i.e.
Set Rng = .Find(What:=MyArr(I, 1), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
I am trying to find values by comparing 2 sheets and then copy the row to another sheet. Any suggestions?
Sub SpecialCopy()
Dim i As Long
Dim cellval, rng As Range
Dim ws1, ws2 As Worksheet
Dim targetSh As Worksheet
Set targetSh = ThisWorkbook.Worksheets("Sheet3")
Set ws2 = Sheets("Sheet2")
Set ws1 = Sheets("sheet1")
ws2.Select
With ActiveSheet
Set rng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
For i = 2 To rng.Rows.Count
Set cellval = ws1.Columns(1).Find(What:=ws2.Range("U" & i).Value, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If cellval Is Nothing Then
Else
Range(Cells(1, i), Cells(33, i)).Copy Destination:=targetSh.Range("A" & targetSh.Cells(Rows.Count, "A").End(xlUp).Row + 1)
End If
Next i
End Sub
Feel that this is piggy-backing on others' comments above, but nobody has submitted an answer so here is my stab. Makes sense to use your sheet variables as you have defined them rather than ActiveSheet, and make sure you follow this through everywhere.
Sub SpecialCopy()
Dim i As Long
Dim cellval As Range, rng As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim targetSh As Worksheet
Set targetSh = ThisWorkbook.Worksheets("Sheet3")
Set ws2 = Sheets("Sheet2")
Set ws1 = Sheets("Sheet1")
With ws2
Set rng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
For i = 2 To rng.Rows.Count
Set cellval = ws1.Columns(1).Find(What:=ws2.Range("U" & i).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not cellval Is Nothing Then
ws2.Range(ws2.Cells(1, i), ws2.Cells(33, i)).Copy Destination:=targetSh.Range("A" & targetSh.Cells(targetSh.Rows.Count, "A").End(xlUp).Row + 1)
End If
Next i
End Sub
I want to get cell number like A:1 for every match found using regex and store it on sheet next to the current in same excel file. Is it possible to achieve in excel. As few of the examples I tried return match found true/false.
Sub Sample()
Dim ws As Worksheet
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set aCell = .Columns(2).Find(What:="Custom ", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
aCell.Value = "Test"
Else
MsgBox "Not Found"
End If
End With
End Sub
This is the sample I tried!!
Try This
Sub Sample()
Dim ws As Worksheet
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set aCell = .Columns(2).Find(What:="Custom ", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1).Value = aCell.Address
Else
MsgBox "Not Found"
End If
End With
End Sub
if you want all the match try below
Sub Sample()
Dim ws As Worksheet
Dim aCell As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
lastrow = Range("B" & Rows.Count).End(xlUp).Row
With ws
For i = 1 To lastrow
If InStr(Range("B" & i), "Custom ") > 0 Then
Worksheets("Sheet2").Range("A" & Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1).Value = Range("B" & i).Address
End If
Next i
End With
End Sub
I am trying to write a macro to copy a range of data from different parts of a worksheet and paste it to a new worksheet. It should do this for every worksheet in the workbook with a few specified exceptions. This is the code I have written so far:
Dim wb As Workbook
Dim ws As Worksheet
Dim Rng As Range
'create new worksheet, name it "Budget"
Set ws = Sheets.Add
ws.Name = "Budget"
'set column titles in the new sheet
Range("A1").Value = "Period"
Range("B1").Value = "Country"
Range("C1").Value = "Product Line"
Range("D1").Value = "Currency"
Range("E1").Value = "Sales"
'search the entire UsedRange of sheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Summary" And ws.Name <> "Template" And ws.Name <> "Data" Then
With ws.UsedRange
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Offset(1, 0).Resize(33)
Sheets("Budget").[F1].End(xlDown).Offset(0, -3).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value 'put values from the Find into C column of new sheet
Set Rng = .Find(What:="201601", _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Offset(1, 0).Resize(33)
Sheets("Budget").[F1].End(xlDown).Offset(0, -1).End(xlUp).Offset(1, 0).Resize(Rng.Rows.Count).Value = Rng.Value 'put values from the Find into D column of new sheet
End With
End If
Next ws
End Sub
The first part seems to work fine, but when it reaches the second "Set Rng" it doesn't go any further. I am looking to set 5 different ranges to take data from.
I've added this as an answer as it's too long to fit in a comment. It's not a perfect answer, but will hopefully highlight a couple of areas to look at.
Each range reference also includes which sheet it's looking at (omitting the sheet reference tells Excel to use the currently active sheet).
An array to populate the headings.
SELECT CASE instead of IF
Space to do something if the FIND's aren't found. You say they're all the same, but that's in a perfect world and I haven't found that yet.
Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsBudget As Worksheet
Dim Rng As Range
Dim rUsedRange As Range
Set wb = ActiveWorkbook
'create new worksheet, name it "Budget"
Set wsBudget = wb.Sheets.Add
With wsBudget
.Name = "Budget"
.Range("A1:E1") = Array("Period", "Country", "Product Line", "Currency", "Sales")
End With
'search the entire UsedRange of sheet.
'ActiveWorkbook or ThisWorkbook?
For Each ws In wb.Worksheets
Select Case ws.Name
Case "Summary", "Template", "Data"
'Do Nothing
Case Else
Set rUsedRange = ws.Range(ws.Cells(1, 1), LastCell(ws))
With rUsedRange
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1, 0).Resize(33).Copy _
Destination:=wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count)
Else
'Do something else if Rng not found.
End If
Set Rng = .Find(What:=201601, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1).Resize(33).Copy _
Destination:=wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count)
Else
'Do something if Rng not found.
End If
End With
End Select
Next ws
End Sub
Have included the find last cell function:
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
This is what I have so far...
Sub Test()
' CreateBudgetFormat Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim wsBudget As Worksheet
Dim Rng As Range
Dim rUsedRange As Range
Set wb = ActiveWorkbook
'create new worksheet, name it "Budget"
Set wsBudget = wb.Sheets.Add
With wsBudget
.Name = "Budget"
.Range("A1:E1") = Array("Period", "Country", "Product Line", "Currency", "Sales")
End With
'search the entire UsedRange of sheet.
For Each ws In wb.Worksheets
Select Case ws.Name
Case "Summary", "Template", "Data"
'Do Nothing
Case Else
For x = 201601 To 201612
Set rUsedRange = ws.Range(ws.Cells(1, 1), LastCell(ws))
With rUsedRange
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1, 0).Resize(32).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something else if Rng not found.
End If
Set Rng = .Find(What:="Product Line", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(37, 0).Resize(2).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -3).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something else if Rng not found.
End If
Set Rng = .Find(What:=x, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(1, 0).Resize(32).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
Set Rng = .Find(What:=x, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(37, 0).Resize(2).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -1).End(xlUp).Offset(1).Resize(Rng.Rows.Count).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
Set Rng = .Find(What:="Ship_To_Country", _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Offset(, 1).Copy
wsBudget.Range("F1").End(xlDown).Offset(, -4).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
Set Rng = .Find(What:=x, _
After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Not Rng Is Nothing Then
Rng.Copy
wsBudget.Range("F1").End(xlDown).Offset(, -5).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
'Do something if Rng not found.
End If
End With
Next
End Select
Next ws
With wsBudget
Range("D2") = "EUR"
Range("C2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
End With
End Sub
It works although far from an ideal code. I would appreciate any help on how I can change this [ wsBudget.Range("F1").End(xlDown).Offset(, -5).End(xlUp).Offset(1).Resize(34).PasteSpecial Paste:=xlPasteValuesAndNumberFormats ] to resize filldown as opposed to having to specify a number of rows (34 in this case). Also any other suggestions of how I can improve the code will be welcome. Thanks!
Well, here is my problem so far, i have a form in VB in this form the user put a number what i want to do is that excel search in Sheet2 If i get this number (if is buyed), and in the active sheet "Data" if is already captured, finally put it in the last empty A row in Sheet1.
I have this so far.
Private Sub CommandButton1_Click()
Me.TextBox1.Text = ""
Me.TextBox2.Text = ""
End Sub
Private Sub CommandButton2_Click()
Dim lastrow As Double
Dim frange As Range
lastrow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
If TextBox1.Text = TextBox2.Text Then
Sheets("Sheet2").Activate
ActiveSheet.Range("A2").Select
If Range("A2:A200").Find(What:=TextBox2.Value _
, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate Then
Sheets("Datos").Activate
If Range("A3:A200").Find(What:=TextBox2.Value _
, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate Then
MsgBox ("This number is already registred")
Else
Cells(lastrow + 1, 1) = TextBox2.Value
End If
Else
MsgBox ("The number has not been buyed")
End If
Else
MsgBox ("The number are not the same")
End If
End Sub
I really hope someone you can help me because i am stuck and i do not see the answer.
Thanks
Sorry for my english
UNTESTED
Please see if this is what you are trying?
Private Sub CommandButton1_Click()
Me.TextBox1.Text = "": Me.TextBox2.Text = ""
End Sub
Private Sub CommandButton2_Click()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim aCell As Range, bCell As Range
Dim lrow As Long
Set ws1 = Sheets("Datos"): Set ws2 = Sheets("Sheet2")
If TextBox1.Text = TextBox2.Text Then
Set aCell = ws2.Columns(1).Find(What:=TextBox2.Value _
, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not aCell Is Nothing Then
Set bCell = ws1.Columns(1).Find(What:=TextBox2.Value _
, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not bCell Is Nothing Then
MsgBox ("This number is already registred")
Else
'~~> This will write to sheet "Datos". if you want to
'~~> write to sheet Sheet2 then change ws1 to ws2 below
With ws1
lrow = ws1.Range("A" & .Rows.Count).End(xlUp).Row + 1
.Cells(lrow, 1) = TextBox2.Value
End With
End If
Else
MsgBox ("The number has not been buyed")
End If
Else
MsgBox ("The number are not the same")
End If
End Sub