I have two sheets. In both sheets I have a column (B) where each row is a different name:
Sheet 'A' has names in the column, these names are 'leading'.
Sheet 'B' also has names in this column, these names CAN BE outdated.
What I want: A macro which can check the names.
delete the names in Sheet B which are not (anymore) in Sheet A (delete entire affecting row)
Add the names from sheet A which are not (yet) in sheet B in new rows
What I have so far:
Sub DeleteRowsThatDoNotMatch()
Dim rng As Range
Dim Rng1 As Range, Rng2 As Range
Dim thisRow As Long
Dim arr1 As Variant
Dim arr2 As Variant
Dim dic2 As Variant
Dim OutArr As Variant
xTitleId = "Test"
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Welke data moet gewijzigd worden? :", xTitleId, Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Selecteer de nieuwe waardes:", xTitleId, Type:=8)
Set Rng1 = Rng1.Columns(1)
Set dic2 = CreateObject("Scripting.Dictionary")
arr2 = Rng2.Value
For i = 1 To UBound(arr2, 1)
xKey = arr2(i, 1)
dic2(xKey) = ""
Next
thisRow = Rng1.Rows.Count
Do While thisRow > 0
If Not dic2.Exists(Rng1.Cells(thisRow, 1).Value) Then
Rng1.Cells(thisRow, 1).EntireRow.Delete
End If
thisRow = thisRow - 1
Loop
End Sub
This works as expected; the problem is adding the names which ARE in Sheet A but not (yet) in Sheet B.
Related
I have a problem in a small part of my code : I want it to select the cells starting from c which is a cell meeting a condition that I have defined earlier, to the end of the list. In this range, I want it to copy the first value that exceeds resultat (a value obtained before).
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
Worksheets("Feuil1").Range(s1 & ":" & s2).Select
For Each Cel In Range(s1 & ":" & s2)
If Cel.Value >= resultat Then
firstValue = Cel.Value
firstAddress = Cel.Address
Exit For
End If
Next
Worksheets("Feuil1").firstValue.Copy
Range("C14").Worksheet("Feuil2").PasteSpecial
I get an error for the 2 first lines of the code.
Thanks a lot for your help.
This is my new code, because I realized something is missing.. The SearchRange does not start from row 2, but from the row where the value (a date) is equal to the last date of ws2. I get an error for my For each line. It says Object required.
Edit - New code, object error at rangyrange :
Private Sub CommandButton1_Click()
Dim rangyrange As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Dim firstAddress As String
Dim Cel As Range
Dim firstValue As Double
Dim A15Value As Date
Dim firsty As Long
Dim newRange As Range
Dim lastRow2 As Long
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Feuil1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Feuil2")
A15Value = CDate(ws2.Cells(15, 1).Value)
With ws1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
Set foundRange = ws1.Range(.Cells(2, 1), .Cells(lastRow, 1))
Set searchRange = foundRange.Find(A15Value, LookIn:=xlValues)
Set rangyrange = ws1.Range(.Cells(searchRange.Row, 1), .Cells(lastRow, 1))
firsty = rangyrange.Rows(1).Row
Set newRange = ws1.Range(.Cells(firsty, 2), .Cells(lastRow2, 2))
End With
For Each ws1Cell In newRange
If ws1Cell.Value >= resultat Then
firstValue = ws1Cell.Value
firstAddress = ws1Cell.Address
Exit For
End If
Next
ws2.Cells(15, 3).Value = firstValue
End Sub
Dim c As Range
Worksheets("Feuil1").Range(Worksheets("Feuil1").Range(c), Worksheets("Feuil1").Range(c).End(xlDown))
You haven't set c to a range, so VBA doesn't understand what you're doing.
Also, I suggest defining a worksheet variable to increase the readability of your code like this:
Set ws = Excel.Application.Worksheets("Feuil1")
And your statement becomes much more legible:
ws.Range(ws.Range(c), ws.Range(c).End(xlDown))
This is not how you reference a range, also, I would suggest never using .Select.
Range(s1 & ":" & s2).Select
This is how you reference a range:
'this is my preferred method of referencing a range
Set someVariable = ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Or...
'this is useful in some instances, but this basically selects a cell
Set someVariable = ws.Range("B2")
Or...
'this references the range A1 to B1
Set someVariable = ws.Range("A1:B1")
Also, as #BigBen pointed out, you cannot set a range like so:
Dim c As Range
s1 = Worksheets("Feuil2").Range(c)
The reasons being:
c hasn't been assigned.
You can't use a range as an input unless it's of the form ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Per your update that includes the assignment for c:
I get an error for the 2 first lines of the code.
This is because you're assigning c before you're declaring c.
You should have all of your Dim statements preceding your actual code (unless you know what you're doing) like so:
Public Sub MySub()
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
`the rest of your code
End Sub
I would change your Do loop to the following:
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do While c.Address <> firstAddress
'I'm unsure of the goal here, so I'm ignoring it
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
Exit Do
End If
Loop
End If
End With
Mainly because I hate GoTo statements and because the MS doc for Do loops states to use either Do While or Do Until instead of Loop While or Loop Until
s1 and s2 are strings, so you can't do this:
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
I'm assuming you want to get the column and row of c and iterate through that, but the problem is that you're working in 2 different worksheets, which you can't do. I'll assume it's an error and that you want to work on the "Fueil2" worksheet, so here goes:
Dim ws2 As Worksheet
Dim startCell As Range
Dim endCell As Range
Dim foundRange As Range
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Fueil2")
With ws2
Set startCell = .Cells(c.Row, c.Column)
Set endCell = .Cells(c.End(xlUp).Row, c.Column)
Set foundRange = .Range(.Cells(c.Row, c.Column), .Cells(c.End(xlUp).Row, c.Column))
For Each Cel In foundRange
'yada yada yada
End With
Post-lunch Edit:
It seems that this is a bit misleading because I tested this snippet and it works:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim workRange As Range
Dim foundColumn As Range
Dim ws1LastCell As Range
Dim ws1Range As Range
Dim iWantThis As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
Set searchRange = ws1.Range("A1:F1")
Set foundRange = searchRange.Find(ws2.Range("C1").Value, LookIn:=xlValues)
With foundRange
'last cell in the ws1 column that's the same column as foundRange
Set ws1LastCell = ws1.Range(ws1.Cells(.Row, .Column), ws1.Cells(ws1.Rows.Count, .Column)).End(xlDown)
'the range you want
Set iWantThis = ws1.Range(foundRange, ws1LastCell)
'check to see if it got what i wanted on ws1
iWantThis.Select
End With
End Sub
New Edit:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim c14Value As Double
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
'gets the date
A14Value = CDate(ws2.Cells(14, 1).Value)
With ws1
'gets the last row's number in column A on worksheet 1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'selects from A2 to the last row with data in it. this works only if
'there aren't any empty rows between your data, and that's what i'm assuming.
Set searchRange = .Range(.Cells(2, 1), .Cells(lastRow, 1))
End With
For Each ws1Cell In searchRange
If CDate(ws1Cell.Value) >= A14Value Then
'i didnt make a variable for firstValue
firstValue = ws1Cell.Value
'i didnt make a variable for firstAddress
firstAddress = ws1Cell.Address
Exit For
End If
Next
'puts firstValue into cell C14 on ws2
ws2.Cells(14, 3).Value = firstValue
End Sub
Until I see a definition for resultat, I'm assuming it's 100% correctly declared and assigned. hint: You should give us your declaration and assignment of resultat because I can't fully determine if how you defined resultat is an issue.
I would like to apply filter on a table based the values presented in cells A1:AG1. But the problem is when my data gets updated, sometimes i have values in other cells like AH,AI etc., The values available only on first row.
So i tried to add a loop for every cell, but it is not working. How to change my code to loop through every column in a single row. Help me
Dim ws As Worksheet
Dim str2 As Variant
Dim arr2() As String
Dim j As Long
Dim rng As Range
Set ws = Sheets("Main")
Set Tbl = Sheet2.ListObjects("DataTable")
Set rng = Range("A1:AG1") 'Need to change
j = 1
For Each cell In rng
str2 = cell.Value
ReDim Preserve arr2(j)
arr2(j) = str2
j = j + 1
Next cell
Tbl.Range.AutoFilter Field:=12, Criteria1:=arr2, Operator:=xlFilterValues
End sub
How about something like below:
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim arr2() As String
Dim i As Long
Set ws = Sheets("Main")
Set ws2 = Sheets("Sheet2")
Set Tbl = ws2.ListObjects("DataTable")
LastCol = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
'above will give you the last column number in row one of sheet ws2
ReDim Preserve arr2(1 To LastCol) 're-size the array
'Set rng = Range("A1:A" & LastCol) 'set your range from column 1 to last
For i = 1 To LastCol 'loop through columns
arr2(i) = ws2.Cells(1, i).Value 'add value to array
'above number 1 represents Row 1, and i will loop through columns
Next i
Tbl.Range.AutoFilter Field:=12, Criteria1:=arr2, Operator:=xlFilterValues
'above will filter table column 12 with array values?
I do not know if I understood your question well, but just replace:
Set rng = Range("A1:AG1")
With:
Set rng = ws.range(ws.cells(1 , 1) , ws.cells(1 , ws.Cells.Columns.Count).End(xlToLeft).Column
I'm attempting to make a Visual Basic Macro to count unique items in a row without doing the copy and pasting and data remove duplicates.
For some reason I'm having issues with my syntax. When I run the script it outputs with the number of rows.
This is my first time programming in Visual Basic for Applications (VBA).
Private Sub FrequencyCount_Click()
Dim rng As Range
Dim outcell As Range
Dim outnum As Integer
Dim MyArray() As Variant
Dim ArrayLength As Integer
Dim unique As Boolean
Dim i
outnum = 0
ArrayLength = 1
unique = False
Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
For Each B In rng.Rows
If outnum = 0 Then
ReDim MyArray(1)
MyArray(ArrayLength) = B.Value
outnum = outnum + 1
ArrayLength = ArrayLength + 1
Else
i = 0
unique = True
Do Until i < ArrayLength
If MyArray(i) = B.Value Then
unique = False
End If
i = i + 1
Loop
MsgBox unique
If unique = True Then
ReDim Preserve MyArray(0 To ArrayLength + 1)
MyArray(ArrayLength) = B.Value
ArrayLength = ArrayLength + 1
outnum = outnum + 1
End If
End If
Next
End
outcell.Value = outnum
End Sub
It is generally considered bad practice to ReDim Arrays in Loop and not recommended. If you search internet then many discussions like this will come up
ReDim in Loop
You can use built-in functionality to get where you want. Example code which should work for you.
Sub FrequencyCount_Click()
Dim rng As Range
Dim outcell As Range
Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
rng.Copy outcell.Cells(1, 1)
outcell.Resize(rng.Cells.Count, 1).RemoveDuplicates 1, xlNo
End Sub
As #RyanWildry suggests, you can use the Dictionary object for this.
The code to call the procedure will also define the range containing the duplicates and the start range to paste the unique values to:
Sub Test()
'This will take values in the first range and paste the uniques starting at the second range cell.
'NB: Search for With...End With.
With ThisWorkbook.Worksheets("Sheet1")
FrequencyCount .Range("B2:B48"), .Range("D2")
End With
End Sub
This code will then place the values into a dictionary, which also removes any duplicates and then uses a couple of techniques to paste back into rows or columns.
I've added lots of comments and this link may help for further reading on the Dictionary object: https://excelmacromastery.com/vba-dictionary/
Public Sub FrequencyCount(SourceRange As Range, TargetRange As Range)
Dim oDict As Object
Dim rCell As Range
Dim vKey As Variant
Dim vArr As Variant
Dim x As Long
Set oDict = CreateObject("Scripting.Dictionary")
oDict.comparemode = vbTextCompare 'Non-case sensitive. Use vbBinaryCompare to make case sensitive.
'Go through each cell in the source range and copy the value to the dictionary.
For Each rCell In SourceRange
'Change the value in the dictionary referenced by key value.
'If key value doesn't exist create it.
oDict(rCell.Value) = rCell.Value
Next rCell
'Paste in rows.
x = 1
ReDim vArr(1 To oDict.Count)
For Each vKey In oDict.Keys
vArr(x) = oDict(vKey)
x = x + 1
Next vKey
TargetRange.Resize(UBound(vArr)) = WorksheetFunction.Transpose(vArr)
'Paste in columns.
TargetRange.Resize(1, UBound(Application.Transpose(oDict.Keys))) = oDict.Keys
End Sub
The problem is you are setting i = 0 then saying
Do until i < arraylength`
Well if i = 0 then it will always be less than arraylength, this probably should be
Do until i > arraylength
Hope this helps :)
This is an more compact solution, I cobbled together from other solutions.
Sub UniqueCountinSelection()
Dim outcell As Range
Dim itms As Object, c As Range, k, tmp As String
Set rng = Application.InputBox("Select a Range to Count Uniques", "Obtain Range Object", Type:=8)
Set outcell = Application.InputBox("Select an Output Box for Uniques", "Obtain Range Object", Type:=8)
Set itms = CreateObject("scripting.dictionary")
For Each c In rng
tmp = Trim(c.Value) 'removes leading and trailing spaces
If Len(tmp) > 0 Then itms(tmp) = itms(tmp) + 1
Next c
outcell.Value = UBound(itms.Keys) + 1
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 have a list of accounts & codes, and would like to populate a column with results from a different sheet using index match. I can get it to work using the formula: =index(rngB,match(BCode,rngM,0),55)
but can't translate it to vba. I have tried:
sub compare()
Dim BudgetResult As Long
Dim var1 As Long
Dim rngB, rngM As Range
Dim CompSH, ActSH, BudSH As Worksheet
Dim BCode As Variant
Set CompSH = Sheets.Add(After:=Sheets(Sheets.Count))
Set ActSH = Sheets(2)
Set BudSH = Sheets(3)
Set rngB = BudSH.Range("B11:BF50")
Set rngM = BudSH.Range("B:B")
Set BCode = CompSH.Range("A2")
BudSH.Select
Range("B10:E76").Select
Selection.Copy
CompSH.Select
ActiveSheet.Paste
Range("F1").Select
ActiveCell.FormulaR1C1 = "Budget"
Range("F2").Select
With Application.WorksheetFunction
var1 = .Match(BCode, rngM, 0)
BudgetResult = .Index(rngB, var1, 55)
End With
I get a blank cell. no result in the sheet.
Also, I don't know how to continue it down. Can anyone help?
you may be after something like follows
Option Explicit
Sub compare()
Dim rngB As Range, rngM As Range, cell As Range
Dim CompSH As Worksheet, ActSH As Worksheet, BudSH As Worksheet
Dim AW As WorksheetFunction: Set AW = Application.WorksheetFunction
Set CompSH = Sheets.Add(After:=Sheets(Sheets.count))
Set ActSH = Sheets("ActSH") 'Sheets(2)
Set BudSH = Sheets("BudSH") 'Sheets(3)
With BudSH
Set rngB = .Range("B11:BF50") '<--| warning: your "index" range has 40 rows
Set rngM = .Range("B:B")
.Range("F1").Value = "Budget"
.Range("B10:E76").Copy CompSH.Range("A1") '<--| warning: your "copied" range has 67 rows
End With
With CompSH
For Each cell In .Range("A2", .Cells(.Rows.count, 1).End(xlUp))
cell.Offset(, 5).Value = AW.Index(rngB, AW.Match(cell, rngM, 0), 55) '<--| this will error when trying to access from 'rngB' range 41th rows on
Next
End With
End Sub
where you only have to adjust the range sizes in the statements marked with <--| Warning...