vlookup and if condition copy data vba - vba

I have a code to copy data from one sheet to another as below but its lookup part is not working. if i do not use this lookup function then code is working good
Sub CopyRows()
Dim Rng As Range
Dim Rng2 As Range
Dim Cl As Range
Dim str As String
Dim RowUpdCrnt As Long
Set UsedRange = Sheets("Jan").Range("b5:bk81")
Set Rng = Sheets("Jan").UsedRange 'the range to search ie the used range
Set Rng2 = Sheets("Feb").Range("I5:AK5")
str = "WRK." 'string to look for
Sheets("Feb").Range("B5:B81").Value = ""
RowUpdCrnt = 5
' In my test data, the "WRK."s are in column AN. This For-Each only selects column AN.
' I assume all my "WRK."s are in a single column. Replace "B" by the appropriate
' column letter for your data.
For Each Cl In Rng.Columns("AN").Rows
If Cl.Text = str Then
'if the cell contains the correct value copy it to next empty row on sheet 2 & delete the row
VLookup(Cl.EntireRow.Range("b1"), Sheets("Master").Range("H7:H200"), 1, 0).Copy
Sheets("Feb").Cells(RowUpdCrnt, 2).PasteSpecial xlPasteValues
RowUpdCrnt = RowUpdCrnt + 1
End If
Next Cl
Application.CutCopyMode = False
End Sub

According to your post, the only thing you want to copy are the values, so you can just qualify the cells (without using Copy >> Paste), by using Sheets("Feb").Range("B" & RowUpdCrnt).Value = Application.VLookup(.Range("B" & Cl.Row).Value, Sheets("Master").Range("H7:H200"), 1, 0)
Try the code below:
With Sheets("Jan")
' loop until last row with data in Column AN (and not the entire column) to save time
For Each Cl In .Range("AN1:AN" & .Cells(.Rows.Count, "AN").End(xlUp).Row)
If Cl.Value Like str Then
'if the cell contains the correct value copy it to next empty row on sheet 2 & delete the row
If Not IsError(Application.VLookup(.Range("B" & Cl.Row).Value, Sheets("Master").Range("H7:H200"), 1, 0)) Then ' <-- verify the VLookup was successful
Sheets("Feb").Range("B" & RowUpdCrnt).Value = Application.VLookup(.Range("B" & Cl.Row).Value, Sheets("Master").Range("H7:H200"), 1, 0)
RowUpdCrnt = RowUpdCrnt + 1
End If
End If
Next Cl
End With

Related

VBA move row data to their related sheet but if duplicate row found then skip that row

I have a sheet named "RAW ITEMS" with data, and also have few more sheets with different name, where i need to move data from "RAW ITEMS" sheet. and all sheet name are available at sheet "RAW ITEMS" in Column C3 to C100.
When I run below code It's works good when I run it first time.
But when I add some data to Sheet "RAW ITEMS", It's also move earlier Rows to their related sheet. I can't figure out how to stop moving duplicate rows.
I mean how to skip if duplicate raw found in those sheets where data are moving?
Sub copyPasteData()
Dim PV As String
Dim ps As String
Dim LastRow As Long
PV = "RAW ITEMS"
Sheets(PV).Visible = True
Sheets(PV).Select
Range("C3").Select
Do While ActiveCell.Value <> ""
ps = ActiveCell.Value
ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
Selection.Copy
Sheets(ps).Visible = True
Sheets(ps).Select
LastRow = pvs("A")
Cells(LastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Sheets(PV).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.Offset(1, 0).Select
Loop
Range("A1").Select
End Sub
Public Function pvs(col)
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
pvs = LastRow
End Function
I am newbies in VBA. Please help me.
how to skip if duplicate raw found in those sheets where data are moving?
This is the file link for better understand
Try the next code, please. It avoids any selection, activation which consumes Excel resources, without bringing any benefit. It should be fast, using arrays and working in memory:
Sub copyPasteData()
Dim PVWs As Worksheet, PSWs As Worksheet, arrPV, arrPS, arPV, arPS
Dim LastRPv As Long, LastRPs As Long, lastCol As Long, i As Long
Dim j As Long, boolCopy As Boolean
Set PVWs = Worksheets("RAW ITEMS")
LastRPv = PVWs.Range("C" & Rows.Count).End(xlUp).Row
lastCol = PVWs.UsedRange.Columns.Count
'load the range in an array:
arrPV = PVWs.Range(PVWs.Range("A" & 2), PVWs.Cells(LastRPv, lastCol)).Value
For i = 1 To UBound(arrPV) 'iterate between the array rows
On Error Resume Next
Set PSWs = Worksheets(CStr(arrPV(i, 3))) 'set the sheet to paste, if no a similar row exists
If Err.Number = 9 Then
Err.Clear: On Error GoTo 0
Dim ans As VbMsgBoxResult
ans = MsgBox("The sheet " & CStr(arrPV(i, 3)) & " does not exist!" & vbCrLf & _
"Would you like to create it?", vbYesNo, "Sheet creation confirmation")
If ans <> vbYes Then GoTo OverIt
Set PSWs = Worksheets.Add(after:=Worksheets(Worksheets.Count)) 'add the new sheet (after the last)
PSWs.Name = arrPV(i, 3) 'name the newly inserted sheet
'copy the header from the previous sheet:
PSWs.Previous.Range("A1:G1").Copy Destination:=PSWs.Range("A1")
End If
On Error GoTo 0
arPV = Application.Index(arrPV, i, 0) 'a slice of the i row (1D array)
LastRPs = PSWs.Range("A" & Rows.Count).End(xlUp).Row 'last row
'load the sheet existing range in an array
arrPS = PSWs.Range(PSWs.Range("A" & 1), PSWs.Cells(LastRPs, lastCol)).Value
For j = 1 To UBound(arrPS) ' iterate and check if the sliced rows are all the elements identic
boolCopy = True
arPS = Application.Index(arrPS, j, 0) 'a slice of the j row (1D array)
If Join(arPV, "|") = Join(arPS, "|") Then 'check if the rows are the same
boolCopy = False: Exit For
End If
Next j
If boolCopy Then
'if not alsready in the sheet, the array is copied
PSWs.Range("A" & LastRPs + 1).Resize(1, UBound(arPV)).Value = arPV
boolCopy = False 'reinitialize the Boolean variable
End If
OverIt:
Next i
End Sub
The code logic assumes that "duplicate row" means that all the cells values on a sheet to copy row are identic whit the one of the analyzed row to be copied.
And in the C column the sheet itself name should exist...

Copy entire row if the column contains any value of another column in VBA

I'm new in VBA.
I have 3 sheets: 'Sunday', 'coords' and 'filtered'.
I want to check if 'A' column of the sheet 'Sunday' is equal any of values in the column 'J' of 'coords' sheet.
If TRUE - copy the row in the 'filtered' sheet.
So far I have tried the following code:
Sub CopyRow()
Dim lastRow As Long
Dim sheetName1 As String
Dim sheetName2 As String
Dim sheetName3 As String
sheetName1 = "Sunday" 'Insert your sheet name here
sheetName2 = "coords"
sheetName3 = "filtered"
lastRow = Sheets(sheetName1).Range("A" & Rows.Count).End(xlUp).Row
For lRow = 2 To lastRow 'Loop through all rows
If Sheets(sheetName1).Cells(lRow, "A") = Sheets(sheetName2).Cells(lRow, "J") Then
c.EntireRow.Copy Worksheets(sheetName3).Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next lRow
End Sub
Any help is greatly appreciated
If you want to check the existence of the value at any row of column J, try this:
If Application.CountIf(Sheets(sheetName2).Columns("J"), Sheets(sheetName1).Cells(lRow, "A").Value2) > 0 Then
Sheets(sheetName3).Range("A" & Rows.count).End(xlUp).offset(1).EntireRow.Value = Sheets(sheetName1).Rows(lRow).Value2
End If

Copy data from one worksheet to other based on condition

I am trying to copy data from one worksheet to another blank worksheet in a workbook. It has three columns where in I want to search a specific 'Unit' value and just copy all of the records with similar 'Unit' values into second worksheet with similar column structure.
**Doc_number** **Doc_version** **Unit**
43449 01 D013-LAG R
43450 02 D013-LAG R
43451 01 D013-DAMP
43452 02 D013-DAMP
Output should be like this if I provide D013-LAG R as input value ;
**Doc_number** **Doc_version** **Unit**
43449 01 D013-LAG R
43450 02 D013-LAG R
I want to paste the selected column to the DELIVERY sheet like if I pass 'Unit' value as 'D03-LAG R' then the output in the DELIVERY file should be just like as follows;
Doc_version Unit
01 D013-LAG R
02 D013-LAG R
It's more like I want to select entire row and then paste the data to another worksheet to the columns I want to. I don't want entire row to be pasted as it is.
I don't have much experience in VBA and have already tried doing the code which results in copying of the last record encountered in the loop. Need your advice.
Sub Row_Copy()
Dim sheet1 As Worksheet, sheet2 As Worksheet
Dim i As Integer, k As Integer
Dim Sheet1LR As Long, Sheet2LR As Long
Set sheet1 = Sheets("MASTER")
Set sheet2 = Sheets("DELIVERY")
Sheet1LR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row + 1
Sheet2LR = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
i = 2
k = Sheet2LR
Do Until i = Sheet1LR
If Trim(sheet1.Cells(i, 26).Value) = "D013-LAG R" Then
With sheet1
.Range(.Cells(i, 1), .Cells(i, 26)).Copy
End With
With sheet2
.Cells(k, 1).PasteSpecial
.Cells(k, 1).Offset(1, 0).PasteSpecial
End With
End If
k = k + 1
i = i + 1
Loop
MsgBox (Complete)
ActiveWorkbook.Save
Application.ScreenUpdating = False
End Sub
This is the latest code I am using;
Sub CommandButton1_Click()
Dim LSearchRow As Long
Dim LCopyToRow As Long
Dim CopyFromSht As Worksheet
Dim CopyToSht As Worksheet
Dim LCnt As Long
On Error GoTo Err_Execute
Set CopyFromSht = Workbooks("TestRow.xlsm").Sheets("MASTER")
Set CopyToSht = Workbooks("TestRow.xlsm").Sheets("DELIVERY")
With CopyFromSht
'Start search in row 4
LSearchRow = .Range("A" & Rows.Count).End(xlUp).Row
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
For LCnt = 2 To LSearchRow
'If value in column Z = "Unit as needed", copy entire row to Sheet2
If .Range("Z" & LCnt).Value = "D013-LAG R" Then
'Select row in Sheet1 to copy
.Rows(LCnt).Copy Destination:=CopyToSht.Rows(LCopyToRow)
'Move counter to next row
LCopyToRow = LCopyToRow + 1
End If
Next LCnt
End With
I wrote a macro that might give you an idea how to resolve your problem:
Sub CopyRows()
' Variables
Dim row_src As Integer
Dim row_dest As Integer
' Inizialize row within destination sheet
row_dest = 1
' Loop over all rows in source sheet
For row_src = 1 To 32767
' Go to correct cell within source sheet
Sheets("Source").Select
Range("B" & CStr(row_src)).Select
' Done if this row is empty
If (ActiveCell.Value = "") Then
Exit For
End If
' Copy row if it's the header or if match found
If (row_src = 1) Or (ActiveCell.Value = "D013-LAG R") Then
' Copy source row
Rows(CStr(row_src) & ":" & CStr(row_src)).Select
Selection.Copy
' Go to destination row
Sheets("Destination").Select
Rows(CStr(row_dest) & ":" & CStr(row_dest)).Select
' Copy row
ActiveSheet.Paste
' Make sure next row is copied on the right place
row_dest = row_dest + 1
End If
Next
End Sub
In case you want to copy only a few columns from the source to the destination sheet, try this:
' Copy columns B to E of source row
Range("B" & CStr(row_src) & ":E" & CStr(row_src)).Select
Selection.Copy
' Go to destination
Sheets("Destination").Select
Range("B" & CStr(row_dest)).Select
' Copy these columns
ActiveSheet.Paste
In case the columns to be copied are not consecutive (for instance B, D and F):
Range("B" & CStr(row_src) & ",D" & CStr(row_src) & ",F" & CStr(row_src)).Select
Range("F" & CStr(row_src)).Activate
Selection.Copy
By the way, I don't know this all by heart.
You can easily find out the details by executing within Excel:
- Menu View/Macro/Register Macro (or something similar; I got the Italian version)
- Do manually anything you want to automate
- Menu View/Macro/Interrput registration
- Menu View/Macro/View/Modify
I hope this helps you

create a macro to copy multiple rows of data from one sheet to another based on a criteria

I am trying to write a macro that will let me copy a range of data from one sheet to another sheet based on a criteria in the column before the column to be copied.
Column B is the criteria column. If there is a 1 in any row in this column then columns C thru AN will be copied from that row where there is a 1 and be pasted into another sheet starting at the top of that sheet.
I have the following code. It locates the first row that satisfies the criteria and copies this row to the second sheet, however the code does not loop thru to find other rows that satisfy the criteria. How can I adjust the code to loop and copy each instance where the criteria is satisfied?
Sub testIt()
Dim i As Integer
Application.ScreenUpdating = False
Sheets("DataDump").Activate
For i = 2 To Range("B2").End(xlDown).Row()
If Range("B" & i).Value = 1 Then
Range("C" & i, "AN" & i).Copy
Sheets("PriceData").Activate
ActiveSheet.Range("B2", "AM2").Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub testIt()
Dim i As Long, shtSrc As Worksheet, rngDest As Range
Application.ScreenUpdating = False
Set shtSrc = Sheets("DataDump")
Set rngDest = Sheets("PriceData").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
For i = 2 To shtSrc.Range("B2").End(xlDown).Row
If shtSrc.Range("B" & i).Value = 1 Then
shtSrc.Range("C" & i & ":AN" & i).Copy rngDest
Set rngDest = rngDest.Offset(1, 0)
End If
Next i
Application.ScreenUpdating = True
End Sub

VBA copy & paste with dynamic range

I'm new with VBA and I'm stuck somewhere. I have to copy last row of column A till column H and paste it untill the last row of column I. Last rows of columnns will be always change.
e.g; my data is in A2:H2 and I5 is the last cell with data.
My code should be copy A2:H2 and paste it A3:H5. And second time I run the macro (after I add new data to respective columns) it should be copy A6:H6 and paste it untill the last row of column I.
I wrote two codes which were not fulfill my needs.
first code is;
Sub OrderList1()
Range("a65536").End(xlUp).Resize(1, 8).Copy _
(Cells(Cells(Rows.Count, 9).End(xlUp).Row, 1))
End Sub
this code skips A3:H4 and only pastes to A5:H5
second code is;
Sub OrderList2()
Range("A2:H2").Copy Range(Cells(2, 8), _
Cells(Cells(Rows.Count, 9).End(xlUp).Row, 1))
End Sub
it copies A2:H3 and paste it A5:H5 but when I add new data it doesn't start to paste from A5:H5. It start from A2:H2 and overwrite to old data.
I can see what I have to change,range should be dynamic range like in the first code,but I can't manage to write the code.
I'll really appreciate little help.
You might want to use this as a starting point:
Dim columnI As Range
Set columnI = Range("I:I")
Dim columnA As Range
Set columnA = Range("A:A")
' find first row for which cell in column A is empty
Dim c As Range
Dim i As Long
i = 1
For Each c In columnA.Cells
If c.Value2 = "" Then Exit For
i = i + 1
Next c
' ok, we've found it, now we can refer to range from columns A to H of the previous row
' to a variable (in the previous row, column A has not been empty, so it's the row we want
' to copy)
Dim lastNonEmptyRow As Range
Set lastNonEmptyRow = Range(Cells(i - 1, 1), Cells(i - 1, 8))
' and now copy this range to all further lines, as long as columnI is not empty
Do While columnI(i) <> ""
lastNonEmptyRow.Copy Range(Cells(i, 1), Cells(i, 8))
i = i + 1
Loop
Try this one for something that allows future functionality, or at least it did for me...Ask if you need help understanding it :)
Option Explicit
Sub lastrow()
Dim wsS1 As Worksheet 'Sheet1
Dim lastrow As Long
Dim lastrow2 As Long
Set wsS1 = Sheets("Sheet1")
With wsS1
'Last row in A
lastrow = Range("A" & Rows.Count).End(xlUp).Row
'Last Row in I
lastrow2 = Range("I" & Rows.Count).End(xlUp).Row
'Cut in A:H and paste into last row on I
wsS1.Range("A2:H" & lastrow).Cut wsS1.Range("I" & lastrow2)
End With
End Sub