I have the code below which does the job I need too. It checks column D to see if the value is bigger than 200, and if it is, then it vlookups in sheet2 to take the corresponding value. However, my approach takes quite time to load because of the loop. Can anyone help me to make the code faster or to have a different approach on it? Thanks
Private Sub CommandButton1_Click()
Dim vlookup As Variant
Dim lastRow1 As Long, lastRow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long
Set ws1 = Sheets("Sheet1")
lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Set ws2 = Sheets("Sheet2")
lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For i = 4 To lastRow1
If Cells(i, "D") > 200 Then
With ws1.Range("g4:g" & lastRow1)
.Formula = "=iferror(vlookup(a4, " & ws2.Range("a2:b" & lastRow2).Address(1, 1, external:=True) & ", 2, false), text(,))"
.value = .value
End With
Else
Cells(i, "g") = "Not found"
End If
Next i
End Sub
put the formula in g4 and copy it down
ws1.Range("g4").formula = "=iferror(vlookup(a4, " & ws2.Range("a2:b" & lastRow2).Address(1, 1, external:=True) & ", 2, false), text(,))"
ws1.Range("g4").copy ws1.Range("g4:G" & lastrow1
Related
I am new to coding and need help with a code that won't complete. I suspect it is due to the size of the data set. I tested the code using a reduced data set and it processes fine. However, my actual data set is over 210,000 rows and is expected to grow.
Is there a way to speed this up? Thank you for your assistance
Sub DupValidation()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim i As Long
Dim lastrow As Long
Dim lastrow2 As Long
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Tickets")
lastrow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws1.Range("g2:g" & lastrow).ClearContents
i = 2
Do While i <= lastrow
If Application.CountIf(ws1.Range(ws1.Cells(2, 2), ws1.Cells(lastrow, 2)), ws1.Cells(i, 2)) > 1 Then
ws1.Cells(i, 7).Value = True
End If
i = i + 1
Loop
End Sub
May be better
Sub Check_Duplicates_Using_Evaluate()
With Range("B2", Range("B" & Rows.Count).End(xlUp))
.Offset(, 5).Value = .Parent.Evaluate("IF(COUNTIF(" & .Address & "," & .Address & ")>1,""True"","""")")
End With
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 would like to copy data from sheet INV_LEDGERSinto Ready to uploadsheet, but the sheet Ready to upload already contains some data and therefore I want to loop through the column A in Ready to upload sheet until it will find the blank cell and then paste the data from INV_LEDGERS.
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet
Dim LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If ws.Range("A" & i) > "" And ws1.Range("A" & i + 1) = "" Then
ws.Range("A" & i & ":AE" & i).Copy
ws1.Range("A" & i + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Else
End If
Next
End Sub
It doesnt show the error msg anymore, but now it copies the data from INV_LEDGERSfrom the row, where data on sheet Ready to upload ends. I mean, that if data on Ready to upload has the end on row 82, the code will take the data from INV_LEDGERS from 82. row, so basically there are missing 81 rows.
Could you advise me, please?
Thanks a lot!
Given the comments from braX, here is my code.
Since you are always starting on the 4th row of the ledger data, you can just copy the entire section and then paste it to your last row + 1 on your upload sheet.
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet
Dim LastRow, LRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
LRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("A4:AE" & LastRow).Copy
ws1.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End Sub
Couple things... have used a With statement, and instead of copy/paste, I'm just making ws1.Value=ws.Value:
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet, LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
With ws
LastRow = .Cells( .Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If .Range("A" & i) > "" And ws1.Range("A" & i + 1) = "" Then
ws1.Range("A" & i + 1 & ":AE" & i + 1).Value = .Range("A" & i & ":AE" & i).Value
End If
Next
End With
End Sub
Edit
Sub CopyLedgers()
Dim ws As Worksheet, ws1 As Worksheet, LastRow As Long
Set ws = Sheets("INV_LEDGERS")
Set ws1 = Sheets("Ready to upload")
With ws
LastRow = .Cells( .Rows.Count, 1).End(xlUp).Row
For i = 4 To LastRow
If IsEmpty(ws1.Range("A" & i + 1)) Then
ws1.Range("A" & i + 1 & ":AE" & i + 1).Value = .Range("A" & i & ":AE" & i).Value
End If
Next
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
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).