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
Related
My code below is supposed to filter data in the wsData and then copy it into the wsTest worksheet after each other in column A. The code works except that it copies the values over each on the destination sheet rather then after each other. Any idea why?
Sub PrintReport()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsForm As Worksheet
Dim wsTest As Worksheet
Dim FrRngCount As Range
Dim i As Integer
Dim k As Integer
Dim t As Integer
Dim s As Integer
Set wbFeeReport = Workbooks("FeExcForm.xlsm")
Set wsData = wbFeeReport.Worksheets("Data")
Set wsTest = wbFeeReport.Worksheets("Test")
wsTest.Cells.Clear
wsData.Activate
i = 1
For k = 1 To 2
With ActiveSheet
.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy Destination:=wsTest.Range("A" & i)
End With
i = wsTest.Range("A" & Rows.Count).End(xlUp)
.AutoFilterMode = False
End With
Next k
End Sub
As first point: if using a range with AutoFilter the copy will always exclude the hidden cells
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
.Copy wsTest.Range("A" & i)
End With
is all you need here.
Regarding your error: On Error Resume Next hides the error of i = wsTest.Range("A" & Rows.Count).End(xlUp) which would return a range rather than a numerical value.
i = wsTest.Range("A" & Rows.Count).End(xlUp).Row + 1
is your friend here :)
Everything together should look something like that:
Sub PrintReport()
Dim wbFeeReport As Workbook
Dim wsData As Worksheet
Dim wsForm As Worksheet
Dim wsTest As Worksheet
Dim FrRngCount As Range
Dim i As Integer
Dim k As Integer
Dim t As Integer
Dim s As Integer
Set wbFeeReport = Workbooks("FeExcForm.xlsm")
Set wsData = wbFeeReport.Worksheets("Data")
Set wsTest = wbFeeReport.Worksheets("Test")
wsTest.Cells.Clear
wsData.Activate
i = 1
For k = 1 To 2
With wsData
.AutoFilterMode = False
With .Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, k
.Copy wsTest.Range("A" & i)
End With
i = wsTest.Range("A" & Rows.Count).End(xlUp).Row + 1
.AutoFilterMode = False
End With
Next k
End Sub
EDIT: For excluding headers just change:
.Copy wsTest.Range("A" & i)
to:
If i = 1 Then .Copy wsTest.Range("A" & i) Else .Offset(1, 0).Copy wsTest.Range("A" & i)
and if you do not want any headers at all then directly use:
.Offset(1, 0).Copy wsTest.Range("A" & i)
But I havent tested it. Just tell me if you get any problems ;)
The below code works great for copying an entire row, how do I make it so I only copy over the first column.
I have tried altering range with no success? Condition is in J, the only column to copy should be 1st one.
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cell.EntireRow.Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Many thanks!
try
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cells(cell.row,1).Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Dim cell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each cell In Sheets(1).Range("J1:J" & lastRow)
If cell.Value = 1 Then
cell.End(xlToLeft).Copy Sheets(5).Cells(i, 1)
i = i + 1
End If
Next
End Sub
Just switch EntireRow to EntireColumn, it is as simple as that! ;)
Dim rCell As Range
Dim lastRow As Long, i As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
i = 1
For Each rCell In Sheets(1).Range("J1:J" & lastRow)
If rcell.Value = 1 Then
rcell.EntireColumn.Copy Sheets(5).Cells(1, i)
i = i + 1
End If
Next rCell
I have two worksheets. WS1 and WS2
WS1 - Column A and WS2 - Column A have product codes.
WS1 - Column B and WS2 - Column B have quantities ordered.
What I would like to do is Compare WS1-A to WS2-A.
If the strings match, then subtract WS2-B from WS1-B.
If no match then go to next row.
I found a bit of code, but since I'm new to VBA, I am not too sure how to modify it to meet my needs.
Public Sub CompareRange(range1 As Range, range2 As Range)
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Integer, lastrow2 As Integer
Dim rng1 As Range, rng2 As Range
Dim CompareCell As Range
Dim CheckCell As Range
Dim CellFound As Boolean
Application.ScreenUpdating = False
Set ws1 = ThisWorkbook.Sheets("Sheet9")
Set ws2 = ThisWorkbook.Sheets("Sheet12")
lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = ws1.Range("A1:A" & lastRow1)
Set rng2 = ws2.Range("A1:A" & lastrow2)
Set qty1 = ws1.Range("B1:B" & lastRow1)
Set qtyair = ws2.Range("B1:B" & lastrow2)
For Each CompareCell In rng1.Cells
CellFound = False
For Each CheckCell In rng2.Cells
If CheckCell.Text = CompareCell.Text Then
End If
Next CheckCell
If Not CellFound Then
End If
Next CompareCell
End Sub
Kindly advise on how I can get this done in Excel VBA. I am using Excel 2013.
sub match_col()
Set ws1 = ThisWorkbook.Sheets("Sheet9")
Set ws2 = ThisWorkbook.Sheets("Sheet12")
lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
i = 1 to lastRow1
j = 1 to lastRow2
if worksheets("ws1_A").range("a" & i).value = worksheets("ws2_A").range("a" & i).value
msgBox worksheets("ws2_B").range("B" & i).value - worksheets("ws1_B").range("B" & i).value
end if
next j
next i
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
I currently have a script (See Below) that adds the contents of every cell in the used rows to another cell in a different worksheet. However, this works for the first 3 cells but will not work for the last 2 for some reason.
Sub Ready_For_Infra()
Dim i As Integer
Dim k As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
For i = 2 To ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row Step 1
For k = 1 To ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
With Worksheets("InfraData")
If ws2.Cells(k, i).Value <> "" Then
ws1.Range("A" & i).Value = ws1.Range("A" & i).Value & ws2.Cells(i, k).Value & Chr(10)
End If
End With
Next k
Next i
MsgBox "Done"
End Sub
This is the data in ws2 (ActionPlan) just in case it helps:
To clarify, it doesn't appear to be appending Cells D2:F3 to the cells I have asked it to. Is anyone able to advise why this might be the case?
Try this code:
Sub Ready_For_Infra()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range
Dim i As Long, lastrow As Long, lastcol As Long
Dim str1 As String
Set ws1 = Worksheets("InfraData")
Set ws2 = Worksheets("ActionPlan")
ws1.Cells.Clear
With ws2
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To lastrow
str1 = ""
For Each cell In .Range(.Cells(i, 1), .Cells(i, lastcol))
If cell.Value <> "" Then str1 = str1 & cell.Value & Chr(10)
Next cell
ws1.Range("A" & i).Value = str1
Next i
End With
MsgBox "Done"
End Sub
Notes:
using For each loop is slightly faster then For k=1 To lastcol
using temporary string variable str1 makes your code faster as well, because in that case you writes result value in ws1.Range("A" & i) cell only once (working with operating memory is always faster than writing subresult in cell for each iteration).