I am trying to make a worksheet function that loops through rows more efficient. Here is what I have -
Dim ws as worksheet, wks as worksheet, lastrow as long, i as long
Set ws = Sheets("Sheet1")
Set wks = Sheets("Sheet2")
With ws
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 to Lastrow
.Range("CS" & i) = Application.Vlookup(ws.Range("B" & i), wks.Range("B2:X100000"),23,false)
next
end with
Thanks!
You should avoid iterating through the rows as much as possible. I would suggest that you instead do a paste of the Vlookup function in the range of the CS column.
This is how it would go if you used the find function:
Dim ws as worksheet, wks as worksheet, lastrow as long, i as long
Set ws = Sheets("Sheet1")
Set wks = Sheets("Sheet2")
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 to Lastrow
ws.Range("CS" & i) = wks.Range("B:B").find(ws.Range("B" & i).Text, , xlValues).Offset(0, 22).Value
Next i
Let me know if it works.
I would remove all the reading and writing on cells from the loop:
Dim rg_table As Range, rg_lookup As Range, values(), r&
Set rg_table = [Sheet1].UsedRange
Set rg_lookup = [Sheet2!B2:X100000]
' load the values to search
values = rg_table.columns("B").Value
' lookup the values
For r = 2 To UBound(values)
values(r, 1) = Application.VLookup(values(r, 1), rg_lookup, 23, False)
Next
' write the results to the sheet
rg_table.columns("CS") = values
Related
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 know this question is as old as time, but I am trying to copy data thats on an excel file, to another, based on multiple criteria.
The destination is called "Test.xlsm" and the source is called "Data.xlsx"
The idea would be for the code to identify the rows that have the text (1,3,D) on the column A, and copy the entire row to the Sheet1 on the destination Test.xlsm
The first row on Test.xlsm has a header so it has to be left alone when copying data to that sheet.
Both files have the destination and source info on sheets called "Sheet1" as default.
I found this code, but i cant adapt it to use a different worksheet for the source, though any code that does the goal is fine.
Sub Copy()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
If Range("A" & r).Value = "1" Or Range("A" & r).Value = "3" Or Range("A" & r).Value = "D" Then
Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
Application.ScreenUpdating = True
End Sub
You'll want to use Workbooks as well, since you are using separate ones, and then set the sheets like the example you provided.
For example:
Dim wkbk1 as Workbook, wkbk2 as Workbook, ws1 as WorkSheet, ws2 as Worksheet
Set wkbk1 = Workbooks.open("C:\path\to\Data.xlsx")
Set wkbk2 = Workbooks.open("C:\path\to\Test.xlsm")
Set ws1 = wkbk1.Sheets("Sheet1")
Set ws2 = wkbk2.Sheets("Sheet1")
From there you can use and modify the code you have.
edit: included OP's workbook and sheet names.
Try this edit or note where I've made edits based on the points in comments - I think this should do well!
Sub CopyThings()
Dim lr As Long, lr2 As Long, r As Long, ws1 As Worksheet, ws2 As Worksheet, n As Long
Application.ScreenUpdating = False
Set ws1 = Application.Workbooks("Data").Worksheets("Sheet1")
Set ws2 = Application.Workbooks("Test").WorkSheets("Sheet1")
n = 1
lr = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For r = 2 To lr
If ws1.Range("A" & r).Value = "1" Or ws1.Range("A" & r).Value = "3" Or ws1.Range("A" & r).Value = "D" Then
ws1.Rows(r).Copy Destination:=ws2.Range("A" & n + 1)
n = ws2.Cells(Rows.Count, "A").End(xlUp).Row
End If
Next r
Application.ScreenUpdating = True
End Sub
Beginner VBA scripter here. How can I fix my code so that it will search thru Sheet1 for the string array in strSearch and copy those rows into Sheet2?
Also, how can I extend the code to be able to search for a different string array and copy it into another worksheet?
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim lastRow As Long
Dim strSearch As Variant
Dim i As Integer
Set ws1 = Worksheets("Sheet1")
With ws1
.AutoFilterMode = False
lRow = .Range("J" & .Rows.Count).End(xlUp).Row
With .Range("J1:J" & lRow)
On Error Resume Next
strSearch = Array("John","Jim")
.AutoFilter Field:=1, Criteria1:=strSearch
Set copyFrom = .Offset(0).SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
End With
Set ws2 = Worksheets("Sheet2")
With ws2
On Error Resume Next
lastRow = ws2.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Set Rng = copyFrom.SpecialCells(xlCellTypeConstants)
Rng.Copy .Cells(lastRow + 1, "C")
copyFrom.Delete
On Error GoTo 0
End With
.AutoFilterMode = False
You could iterate through the lines and the array:
Option Explicit
Dim firstRowWs1 As Long
Dim lastRowWs1 As Long
Dim lastRowWs2 As Long
Dim searchColumnWs1 As Integer
Dim i As Integer
Dim check As Variant
Dim strSearch As Variant
Sub test()
lastRowWs1 = ws1.UsedRange.Rows.Count
lastRowWs2 = ws2.UsedRange.Rows.Count
firstRowWs1 = 2
searchColumnWs1 = 1
strSearch = Array("John", "Jim")
For i = firstRowWs1 To lastRowWs1
For Each check In strSearch
If check = ws1.Cells(i, searchColumnWs1).Value Then
ws1.Rows(i).Copy (ws2.Rows(lastRowWs2 + 1))
lastRowWs2 = lastRowWs2 + 1
ws1.Rows(i).Delete shift:=xlUp
i = i - 1
Exit For
End If
Next check
Next i
End Sub
Dim strsearchlocation as integer
strSearchLocation = Sheet1.Cells.Find(what:= strSearch, After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).row
Sheet1.Rows(strSearchLocation).Copy
Finds and copies the row of strSearch
I was writing a code to select all the data entries of a Workbook which I 'Open' in a range, but the compiler gives error at the very last line (set up the Range rng)
Dim wb As Workbook
Set wb = Workbooks.Open(Range("C2") & Range("C3"))
'here Range("C2") & Range("C3") contains the location of the file's path
Dim ws As Worksheet
Set ws = wb.ActiveSheet
Dim frow As Long
frow = ws.Range("A" & Rows.count).End(xlUp).Row
Dim rng As Range
Dim frow1 As Long
frow1 = ws.Cells(1, Columns.count).End(xlToLeft).Column
Set rng = wb.ActiveSheet.Range(Cells(1, 1), Cells(frow, frow1))
Try:
Dim frow As Long
frow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
Dim rng As Range
Dim fcol As Long
fcol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(frow, fcol))
Remember that if you are using a set worksheet u have to reference it in all range objects
I have an Excel sheet with names as one column and their working hours as values in next column.
I want to copy names with values greater than 40 to new sheet without any blanks in columns. The new sheet should have both names and the working hours; any text in the values column should be ignored.
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
For i = 1 To lastrow1
If sh1.Cells(i, "F").Value > 20 Then
sh2.Range("A" & i).Value = sh1.Cells(i, "F").Value
End If
Next i
End Sub
I would recommend using AutoFilter to copy and paste as it is faster than looping. See the example below.
My Assumptions
Original Data is in Sheet 1 as shown the snapshot below
You want the output in Sheet 2 as shown the snapshot below
CODE
I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long
'~~> Set the input sheet
Set wsI = Sheets("Sheet1"): Set wsO = Sheets("Sheet2")
'~~> Clear Sheet 2 for output
wsO.Cells.ClearContents
With wsI
'~~> Remove any existing filter
.AutoFilterMode = False
'~~> Find last row in Sheet1
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Filter Col B for values > 40
With .Range("A1:B" & lRow)
.AutoFilter Field:=2, Criteria1:=">40"
'~~> Copy the filtered range to Sheet2
.SpecialCells(xlCellTypeVisible).Copy wsO.Range("A1")
End With
'~~> Remove any existing filter
.AutoFilterMode = False
End With
'~~> Inform user
MsgBox "Done"
End Sub
SNAPSHOT
Try rhis
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
j = 1
For i = 1 To lastrow1
If Val(sh1.Cells(i, "F").Value) > 20 Then
sh2.Range("A" & j).Value = sh1.Cells(i, "F").Value
j = j + 1
End If
Next i
End Sub