I have the following code which compares two different sheets at the same time.
Dim compareRange As Range
Dim toCompare As Range
Dim rFound As Range
Dim cel As Range
Set compareRange = Worksheets("sheet2").Range("A1:A" & Lastrow3)
Set toCompare = Worksheets("sheet3").Range("A1:A" & Lastrow4)
Set rFound = Nothing
For Each cel In toCompare
Set rFound = compareRange.Find(cel)
Z = compareRange.Find(cel).Row
If Not rFound Is Nothing Then
cel.EntireRow.Interior.Color = vbGreen
Set rFound = Nothing
End If
Next cel
However this only compares column A's when I want to compare column A's C'd and D's at the same time and only pass when all three match. The sheets have duplicate values that is why I need to compare 3 items at a time but some columns are identical. I have to use a nested loop. Any idea where to start?
I thought I could do something like
Set compareRange = Worksheets("sheet2").Range("A1:A, C1:C, D1:D" & Lastrow3)
But apparently I can't
Actually you are not comparing other two columns in your code. Try below code.
Sub Demo()
Dim compareRange As Range, toCompare As Range
Dim lastRow1 As Long, lastRow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long
Set ws1 = ThisWorkbook.Worksheets("Sheet2")
Set ws2 = ThisWorkbook.Worksheets("Sheet3")
lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
Set compareRange = ws1.Range("A1:A" & lastRow1)
Set toCompare = ws2.Range("A1:A" & lastRow2)
For i = 1 To lastRow2
For j = 1 To lastRow1
If ws2.Cells(i, 1) = ws1.Cells(j, 1) And ws2.Cells(i, 3) = ws1.Cells(j, 3) And ws2.Cells(i, 4) = ws1.Cells(j, 4) Then
ws2.Cells(i, 1).Interior.Color = vbGreen
Exit For
End If
Next j
Next i
End Sub
Let me know if anything is not clear.
Related
I have written a small code that allow me to:
in a defined range (xrng) in column F, find all the cells that contain certain text and once found, select all the cells in the range A:G on the same row and delete them. I have a reverse loop, which work partially, as ignores some cells in the range, specifically the 2nd and the 3rd. Below a before and after pic:
Here my code:
Sub removeapp()
Dim g As Long, xrng As Range, lastrow As Long, i As Long
i = 4
lastrow = Cells(Rows.Count, "F").End(xlUp).Row
Set xrng = Range(Cells(lastrow, "F"), Cells(i, "F"))
For g = xrng.Count To i Step -1
If xrng.Cells(g).Value = "Adjustment" Or xrng.Cells(g).Value = "Approved" Then
Range(Cells(xrng.Cells(g).Row(), "A"), Cells(xrng.Cells(g).Row(), "G")).Delete
End If
Next
End Sub
Could you help me to figure out why?
Also, the code runs really slow... if you have any tip to make it slighlty faster would be great!
Try this, please:
Sub removeappOrig()
Dim xrng As Range, lastrow As Long, sh As Worksheet
Set sh = ActiveSheet 'good to put here your real sheet
lastrow = sh.Cells(sh.Rows.count, "F").End(xlUp).Row
Set xrng = sh.Range("A4:F" & lastrow)
xrng.AutoFilter field:=6, Criteria1:="=Adjustment", Operator:=xlOr, _
Criteria2:="=Approved", VisibleDropDown:=False
Application.DisplayAlerts = False
xrng.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
sh.AutoFilterMode = False
End Sub
The next code is also fast enough since it iterates between array elements (in memory), not deletes row by row (it creates a ranges Union) and delete all at once:
Private Sub remoRangesAtOnce()
Dim i As Long, lastRow As Long, sh As Worksheet
Dim arrF As Variant, rng As Range, rngDel As Range
Set sh = ActiveSheet 'please name it according to your sheet name
lastRow = sh.Cells(sh.Rows.count, "F").End(xlUp).Row
Set rng = sh.Range("F4:F" & lastRow)
arrF = rng.Value
For i = LBound(arrF) To UBound(arrF)
If arrF(i, 1) = "Adjustment" Or arrF(i, 1) = "Approved" Then
If rngDel Is Nothing Then
Set rngDel = sh.Range(sh.Range("A" & i + 3), sh.Range("F" & i + 3))
Else
Set rngDel = Union(rngDel, sh.Range(sh.Range("A" & i + 3), sh.Range("F" & i + 3)))
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.Delete xlShiftUp
End Sub
I have two sheets. Sheet1 (PasteHere) has a long list of values in col B. For example:
100000
100100
100800
100801
200501
etc
Sheet2 (Landing) has a list I need to filter by. For example:
100000
100801
The end result is that I would like the values in sheet 1 to be filtered by the values in sheet 2. I am thinking I could name the range in sheet 2 and then filter by it, but it is not working. Here is the code I have so far. I am naming the range "CustList"
Sub FilterList()
Sheets("Landing").Select
Dim LastRow1 As Long
LastRow1 = Range("B" & Rows.Count).End(xlUp).Row
Range("B15:B" & LastRow1).Select
ActiveWorkbook.Names.Add Name:="CustList", RefersToR1C1:= _
"=Landing!R15C2:R[" & LastRow1 & "]C2"
Range("E16").Select
Dim vCrit As Variant
Dim rngCrit As Range
Set rngOrders = Sheets("PasteHere").Range("$A$1").CurrentRegion
Set rngCrit = Sheets("Landing").Range("CustList")
vCrit = rngCrit.Value
Sheets("PasteHere").Select
rngOrders.AutoFilter _
Field:=2, _
Criteria1:=Application.Transpose(vCrit), _
Operator:=xlFilterValues
End Sub
Use the below code.
Dim LastRow1, LastRow2, iLoop
Sheets("Landing").Select
LastRow1 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
ReDim xarr(LastRow1 - 14)
For iLoop = 1 To LastRow1 - 14
xarr(iLoop) = ActiveSheet.Range("B" & iLoop)
Next
Sheets("PasteHere").Select
LastRow2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("B1").Select
Selection.AutoFilter
ActiveSheet.Range("$B$1:$B$" & LastRow2).AutoFilter Field:=1, Criteria1:=xarr, Operator:=xlFilterValues
Try this code:
Option Explicit
Sub FilterRange()
'declaration of variables
Dim filterBy As Variant, toFilter As Variant, lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, k As Long, _
filtered As Variant, ws1 As Worksheet, ws2 As Worksheet, flag As Boolean
k = 1
flag = True
'set references to worksheets, it's good to use them when you deal with more than one worksheet
'REMEMBER: use your own sheet name and change ranges I used (I used A column)
Set ws1 = Worksheets("Arkusz1")
Set ws2 = Worksheets("Arkusz2")
'set the ranges (storethem as arrays): to filter and one to filter by
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
toFilter = ws1.Range("A1:A" & lastRow1).Value2
'clear range, we will write here filtered values
ws1.Range("A1:A" & lastRow1).Clear
lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
filterBy = ws2.Range("A1:A" & lastRow1).Value2
'here you loop thorugh arrays, checking if one element is in the other array
'if it isn't, write this value to cell on ws1
For i = 1 To lastRow1
flag = True
For j = 1 To lastRow2
If toFilter(i, 1) = filterBy(j, 1) Then
flag = False
Exit For
End If
Next
If flag Then
ws1.Cells(k, 1).Value = toFilter(i, 1)
k = k + 1
End If
Next
End Sub
I have about 34,000 lines of data in a worksheet and I need too hide rows that does not have matching data in another worksheet. I have some code but i seems to hide all the data instead of jst hiding the data which is not represented in the other worksheet. The code is shown below and any help would be appreciated!
Sub HideCells()
Dim xlRange As Range
Dim xlCell As Range
Dim xlSheet As Worksheet, sht As Worksheet
Dim valueToFind
Dim i As Long, lastrow As Long, lastrow2 As Long
Set xlSheet = ActiveWorkbook.Worksheets("Køb VT nummer")
lastrow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(xlUp).Row
Set xlRange = xlSheet.Range("A1:A" & lastrow)
Set sht = ActiveWorkbook.Worksheets("køb total")
lastrow2 = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Debug.Print lastrow
Debug.Print lastrow2
For i = 2 To lastrow2
valueToFind = Sheets("køb total").Cells(i, 7).Value
For Each xlCell In xlRange
If Not xlCell.Value = valueToFind Then
Worksheets("Køb total").Rows(i).EntireRow.Hidden = True
Exit For
End If
Next xlCell
Next i
End Sub
This is because a line containing "ValueToFind" for one value of "i" doesn't necessarily contain it for a different value of "i"
Try
Worksheets("Køb total").usedRange.rows.hidden = true
For i = 2 To lastrow2
valueToFind = Sheets("køb total").Cells(i, 7).Value
For Each xlCell In xlRange
If xlCell.Value = valueToFind Then
Worksheets("Køb total").Rows(i).EntireRow.Hidden = False
End If
Next xlCell
Next i
Your code will run much faster if you do all the hiding at the end of the checking.
Sub HideCells()
Dim xlRange As Range
Dim xlCell As Range
Dim xlSheet As Worksheet, sht As Worksheet
Dim i As Long, lastrow As Long, lastrow2 As Long
Dim rngHide As Range, c As Range
Set xlSheet = ActiveWorkbook.Worksheets("Køb VT nummer")
lastrow = xlSheet.Cells(xlSheet.Rows.Count, "A").End(xlUp).Row
Set xlRange = xlSheet.Range("A1:A" & lastrow)
Set sht = ActiveWorkbook.Worksheets("køb total")
lastrow2 = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For Each c In sht.Range("G2:G" & lastrow2)
'any match on the other sheet?
If IsError(Application.Match(c.Value, xlRange, 0)) Then
If rngHide Is Nothing Then
Set rngHide = c
Else
Set rngHide = Application.Union(rngHide, c)
End If
End If
Next c
'any rows to hide? If Yes then hide them all
If Not rngHide Is Nothing Then rngHide.EntireRow.Hidden = True
End Sub
I have created macro that works like a vlookup but has split values. I would like to find value from second sheet of split values (separated by semicolon ) and copy and paste the description to new sheet.
The first loop goes through the list in sheet 2 and sets the value in a variable, the second loop through split values checks when there is exact match and the description is copied and pasted to the second sheet.
However - it doesn't work and I don't know what the problem is.
I have notification "type mismatch".
I tried vlookup with part text string but it doesn't work either.
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr = variable Then
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
Next i
Else
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
End If
End If
Next
End If
Next
End With
End Sub
I changed my code but it is still not work properly, I have a result:
try this
Sub test()
Dim Cl As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
With Sheets("Sheet1")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
If Cl.Value <> "" Then
Dic.Add Cl.Row & "|" & Replace(LCase(Cl.Value), ";", "||") & "|", Cl.Offset(, 1).Text
End If
Next Cl
End With
With Sheets("Sheet2")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each Key In Dic
If Key Like "*|" & LCase(Cl.Value) & "|*" And Cl.Value <> "" Then
Cl.Offset(, 1).Value = Dic(Key)
Exit For
End If
Next Key
Next Cl
End With
End Sub
Output Result
Sub YourVLookup()
Dim rng As Variant, rng2 As Variant
Dim lastRow As Long, i As Long, j As Long, k As Long
Dim aCell As Variant, bCell As Variant
Dim myAr() As String, variable As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow)
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow)
For i = LBound(rng2, 1) To UBound(rng2, 1)
If Len(Trim(rng2(i, 1))) <> 0 Then
variable = rng2(i, 1)
For j = LBound(rng, 1) To UBound(rng, 1)
If Len(Trim(rng(j, 1))) <> 0 Then
If InStr(1, rng(j, 1), ";") > 0 Then
myAr = Split(rng(j, 1))
For k = LBound(myAr) To UBound(myAr)
If myAr(k) = variable Then
rng2(i, 2) = myAr(k)
End If
Next k
ElseIf rng(j, 1) = rng2(i, 1) Then
rng2(i, 2) = rng(j, 2)
End If
End if
Next j
End If
Next i
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow) = rng
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow) = rng2
End Sub
You were pasting something that you don't have copied already, you forgot to close a With, and you can't use bCell(,2), so
Try this :
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr() As String
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
End With
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr(i) <> variable Then
Else
'You were pasting nothing with that
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
Next i
Else
'Same here
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
End If
Next aCell
End If
Next bCell
End With
End Sub
I have two sheets. I want to check the value in one column against the value in the same column in the second sheet. If they match, then I want to migrate the string data from the Notes column to the new sheet. (essentially I'm seeing if last week's ticket numbers are still valid this week, and carrying over the notes from last week).
I am trying to do this with the following code (using columns Z for the data, BE for the notes):
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Dim partNo2 As Range
Dim partNo1 As Range
Dim partNo3 As Range
For Each partNo2 In ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo1 In ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each partNo3 In ws1.Range("BE1:BE" & ws2.Range("BE" & Rows.Count).End(xlUp).Row)
If StrComp(Trim(partNo2), Trim(partNo1), vbTextCompare) = 0 Then
ws2.Range("BE" & partNo1.Row) = partNo3
End If
Next
Next
Next
'now if no match was found then put NO MATCH in cell
For Each partNo1 In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If IsEmpty(partNo1) Then partNo1 = ""
Next
End Sub
Untested:
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range, rng2 As Range
Dim c As Range, f As Range
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set rng1 = ws1.Range("Z1:Z" & ws1.Range("Z" & Rows.Count).End(xlUp).Row)
Set rng2 = ws2.Range("Z1:Z" & ws2.Range("Z" & Rows.Count).End(xlUp).Row)
For Each c In rng1.Cells
Set f = rng2.Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
f.EntireRow.Cells(, "BE").Value = c.EntireRow.Cells(, "BE").Value
End If
Next c
'now if no match was found then put NO MATCH in cell
For Each c In ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If Len(c.Value) = 0 Then c.Value = "NO MATCH"
Next
End Sub
This accomplishes the same result (maybe with the exception of the columns E & F at the bottom with NO MATCH). It's just a different way of going about it. Instead of using ranges, I'm just looking at each cell and comparing it directly.
TESTED:
Sub NoteMatch()
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim tempVal As String
lastRow1 = Sheets("Sheet1").Range("Z" & Rows.Count).End(xlUp).row
lastRow2 = Sheets("Sheet2").Range("Z" & Rows.Count).End(xlUp).row
For sRow = 2 To lastRow1
tempVal = Sheets("Sheet1").Cells(sRow, "Z").Text
For tRow = 2 To lastRow2
If Sheets("Sheet2").Cells(tRow, "Z") = tempVal Then
Sheets("Sheet2").Cells(tRow, "BE") = Sheets("Sheet1").Cells(sRow, "BE")
End If
Next tRow
Next sRow
Dim match As Boolean
'now if no match was found, then put NO MATCH in cell
For lRow = 2 To lastRow2
match = False
tempVal = Sheets("Sheet2").Cells(lRow, "Z").Text
For sRow = 2 To lastRow1
If Sheets("Sheet1").Cells(sRow, "Z") = tempVal Then
match = True
End If
Next sRow
If match = False Then
Sheets("Sheet2").Cells(lRow, "BE") = "NO MATCH"
End If
Next lRow
End Sub