VBA copy row from one sheet to another based on 2 criteria - vba

i have 2 sheeets. basically ws1 is the destination, ws2 is the source. then i have 2 criterias, an ID Number, and a name of the person who will work on the ID Number.
source contains a row with new actions/progress done by "working person" and need to paste it on the destination in order to update it.
I've read around and saw that autofilter looks like the way to go. i have a code here that autofilters, but i'm just not sure how i can "attack" the problem.
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrowDest As Long, currow As Long, lastrowSrc As Long
Dim critvalue1 As String
'Destination sheet (dashboard)
Set ws1 = Sheets("Destination")
'Source Sheet (source)
Set ws2 = Sheets("Source")
lastrowSrc = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
lastrowDest = ws1.Range("A" & Rows.Count).End(xlUp).Row
For currow = 2 To lastrowSrc
critvalue1 = ws2.Range("E" & currow).Value
ws1.Range("A1").AutoFilter field:=5, Criteria1:=critvalue1
Next currow
end sub
is there an easy way to copy the row from source to destination provided that the IDnumber matches? (the IDnumber is unique)
the code above filters but i'm not sure of how to copy or move the rows.
thanks in advance.

This could be done with SUMPRODUCT or VLOOKUP but if you are set on VBA then try this
Sub copyRow()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrowDest As Long, currowSrc As Long, currowDest As Long, lastrowSrc As Long
Dim critvalue1 As String
Set ws1 = Sheets("Sheet2")
Set ws2 = Sheets("Sheet1")
lastrowSrc = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
lastrowDest = ws1.Range("A" & Rows.Count).End(xlUp).Row
For currowSrc = 2 To lastrowSrc
critvalue1 = ws2.Range("E" & currowSrc).Value
ws2.Cells(6, 5).Value = critvalue1
For currowDest = 2 To lastrowDest
If ws1.Range("E" & currowDest).Value = critvalue1 Then
ws2.Rows(currowSrc).Copy Destination:=ws1.Range("A" & currowDest)
End If
Next currowDest
Next currowSrc
End Sub
I find it easier than dealing with the autofilter. It goes row by row from the source sheet and checks for a match in every row of the destination sheet. If there is a match, the source row in copied to the matching destination row.
To keep formatting instead of
ws2.Rows(currowSrc).Copy Destination:=ws1.Range("A" & currowDest)
use
ws2.Rows(currowSrc).Copy
ws1.Range("A" & currowDest).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats

I pulled this out of a larger macro I use and made some changes to make it match your method a little better and I deleted some irrelevant stuff. The variable names are a bit different. I believe this does what you need. Let me know if it gives you trouble.
Don't forget to populate the ID and Name arrays, set the value for the 2 column variables and assign the sheet names before running.
Sub copyByAutofilter()
Dim filterList1 As Variant
filterList1 = Array("ID1", "ID2")
filterCol1 = 1 'or whatever column contains the IDs
Dim filterList2 As Variant
filterList2 = Array("Name1", "Name2")
filterCol2 = 2 'or whatever column contains the names
Dim sourceWB As String
sourceWB = ThisWorkbook.Name
Dim sourceWS As String
sourceWS = "Sheet2"
Dim destinationWB As String
destinationWB = ThisWorkbook.Name
Dim destinationWS As String
destinationWS = "Sheet3"
lastrowSrc = Sheets(sourceWS).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
lastrowDest = Sheets(destinationWS).Range("A" & Rows.Count).End(xlUp).Row
Workbooks(sourceWB).Sheets(sourceWS).AutoFilterMode = False
Workbooks(sourceWB).Sheets(sourceWS).Range("$A$1:$O" & lastrowSrc).AutoFilter Field:=filterCol1, _
Criteria1:=filterList1, Operator:=xlFilterValues
Workbooks(sourceWB).Sheets(sourceWS).Range("$A$1:$O" & lastrowSrc).AutoFilter Field:=filterCol2, _
Criteria1:=filterList2, Operator:=xlFilterValues
Workbooks(sourceWB).Sheets(sourceWS).Range("A2:O" & lastrowSrc).SpecialCells _
(xlCellTypeVisible).Copy _
Destination:=Workbooks(destinationWB).Sheets(destinationWS).Cells(lastrowDest + 1, 1)
End Sub

One method is by using the Copy method of the Range object. This should generally be avoided though as this overwrites the clipboard. A safer option is to simply use rngDest.Value = rngSrc.Value. Note that for this to work the ranges must be the same size. Here is how this is normally used:
Dim dst As Range
Dim src As Range
Set src = Range("A1:B3") 'Data you want to copy
Set dst = Range("C1") 'First cell in the destination Range
Set dst = dst.Resize(src.Rows.Count, src.Columns.Count) 'Resize to match src
dst.Value = src.Value 'Copy to destination
This method has the benefit of preserving the clipboard!

Related

Dynamic discontinuous excel ranges in VBA

How can I dynamically extend the number of rows in two columns that I need to copy to another sheet?
First, I identify the number of rows I need to include and store in totrows:
Dim totrows As Integer
With ThisWorkbook.Worksheets("Sheet1")
totrows = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Next, I am trying to extend the two columns of interest ("B" and "G") so that the range includes that totrows rows. For a static example, if totrows=100 then I would have:
With ThisWorkbook.Worksheets("Sheet1")
.Range("B2:B102,G2:G102").copy
End With
I then paste them into my second sheet with:
ThisWorkbook.Worksheets("Sheet2").Range("A2").Paste
.Range("B2:B102,G2:G102").copy
can be written as
.Range("B2:B" & totrows & ",G2:G" & totrows).Copy
Another way without using .Copy or .Paste would be this:
Sub Copy()
Dim wb As Workbook
Dim wsCopy As Worksheet
Dim wsPaste As Worksheet
Dim totrows As Integer
Set wb = Workbooks("Book1.xlsm")
Set wsCopy = wb.Worksheets("Sheet1")
Set wsPaste = wb.Worksheets("Sheet2")
totrows = wsCopy.Range("A" & wsCopy.Rows.Count).End(xlUp).Row
wsPaste.Range("A1:B" & totrows) = wsCopy.Range("A2:A" & totrows, "G2:G" & totrows).Value
End Sub
This way your directly putting the Values into the Range you want.

Use value from column in one workbook to search column in another workbook

I'm having trouble with the code below.
I'm trying to use the values from column "A" in wb2 to search in column "G" in wb1.
Column "A" in wb2 contains a long list of numbers and I'm trying to search a exact match of that number in column "G" in wb1.
When there's a match I need it to set the value of column "AF" at the correct row in wb2 to the corresponding match from wb1, but from another column, maybe column "Z" instead of "G".
The to workbooks are already open, when running the macro.
Hope you can help me out.
Thanks in advance.
Sub ROAC()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim y As Integer
Dim sht As Worksheet
Set wb1 = Workbooks("EP_BB_DK_ny.xlsm")
Set wb2 = Workbooks("Laaneoversigt.xlsm")
Set sht = wb2.Worksheets("oversigt")
LastRow = sht.Cells(sht.Rows.Count, "AF").End(xlUp).Row
LastRowWb1 = wb1.Sheets("Period").Range(wb1.Sheets("Period").Range("G1"), wb1.Sheets("Period").Range("G1").End(xlDown)).Rows.Count
LastRowWb2 = wb2.Sheets("Oversigt").Range(wb2.Sheets("Oversigt").Range("A1"), wb2.Sheets("Oversigt").Range("A1").End(xlDown)).Rows.Count
For y = 7 To LastRowWb1
For x = 1 To LastRowWb2
If wb1.Sheets("Period").Range("G" & y).Value = wb2.Sheets("Oversigt").Range("A" & x).Value Then
wb2.Sheets("Oversigt").Range("AF" & LastRow).Offset(1, 0).Value = wb1.Sheets("Period").Range("G" & y)
End If
Next x
Next y
End Sub
Here's how I would look to carry out your requirement (assuming I understood it clearly enough anyway!). This code loops through all rows in column A in wb2, and performs a Find operation against column G in wb1. Where it's found, it sets AF column in wb2 for that row to be the value from wb1's Z column on the same row.
Sub ROAC()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim y As Integer
Dim sht As Worksheet
Set wb1 = Workbooks("EP_BB_DK_ny.xlsm")
Set wb2 = Workbooks("Laaneoversigt.xlsm")
Set wb1sht = wb1.Worksheets("Period")
Set wb2sht = wb2.Worksheets("oversigt")
LastRowWb1 = wb1sht.Cells(wb1sht.Rows.Count, "G").End(xlUp).Row
LastRowWb2 = wb2sht.Cells(wb2sht.Rows.Count, "A").End(xlUp).Row
For y = 1 To LastRowWb2
findMe = wb2sht.Range("A" & y).Value
With wb1sht.Range("G7:G" & LastRowWb1)
Set oFound = .Find(findMe)
If Not oFound Is Nothing Then
' Found number - set AF in wb2 on this row to Z on the same row from wb1
wb2sht.Range("AF" & oFound.Row).Value = wb1sht.Range("Z" & oFound.Row).Value
Else
' Didn't find number, so do whatever you might need to do to handle this in here...
End If
End With
Next
End Sub
This should fix your issue ( I've not wrote this in VBA so there might be the odd syntax issue).
Essentially, you can 'Find' your value in wb1 and if its there paste that value into wb2.
Sub ROAC()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim y As Integer
Dim sht As Worksheet
Dim fndRange as Range
Dim wb1Value as variant
Set wb1 = Workbooks("EP_BB_DK_ny.xlsm")
Set wb2 = Workbooks("Laaneoversigt.xlsm")
Set sht = wb2.Worksheets("oversigt")
LastRow = sht.Cells(sht.Rows.Count, "AF").End(xlUp).Row
LastRowWb1 = wb2.Sheets("Period").Range("G" & Rows.Count).End(xlUp).Row
LastRowWb2 = wb2.Sheets("Oversigt").Range("A" & Rows.Count).End(xlUp).Row
For y = 7 To LastRowWb1
wb1Value = wb1.Sheets("Period").Range("G" & y).Value
Set fndRange = wb2.Sheets("Oversigt").Range("A1:A" & LastRowWb2).Find(What:= wb1Value)
If Not fndRange is Nothing Then
wb2.Sheets("Oversigt").Range("AF" & LastRow).Offset(1, 0).Value = wb1.Sheets("Period").Range("G" & fndRange.Row)
End If
Next y
End Sub
Sub ROAC()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Target_Data As Range
Dim y As Integer
'Since you were using same sheets over and over, I just set ws1 and ws2
'instead of writing Wb1.Sheets("Period") wb2.Sheets("Oversigt") everytime
Set ws1 = Workbooks("EP_BB_DK_ny.xlsm").SHEETS("Period")
Set ws2 = Workbooks("Laaneoversigt.xlsm").SHEETS("Oversigt")
lastrow = ws2.Cells(ws2.Rows.Count, "AF").End(xlUp).Row
LastRowWb1 = ws1.Range(ws1.Range("G1"), ws1.Range("G1").End(xlDown)).Rows.Count
For y = 7 To LastRowWb1
''''This compares ws1.Range("G" & y) with ws2.Column A and set Target_Data as matching range
Set Target_Data = ws2.Columns("A").Find(ws1.Range("G" & y).Value)
''''This check if the Target_data found data or not (Find method will return Nothing if it doesn't find it.)
If Not (Target_Data Is Nothing) Then
''''''''This will write ws1. Column Z's data to ws2. Column AF on same row as where the data is found
ws2.Range("AF" & Target_Data.Row) = ws1.Range("Z" & y)
End If
Next y
End Sub
I might be little off on getting source data and target data.
It's really confusing
Anyway, You can play around with it to make it work :)

Copy data data from one worksheet to another with a condition

I'm working on a macro that helps me to copy data from one worksheet to another in Excel with some conditions. I tried the following code; it works, but I got an infinite loop and I was not able to make the condition correctly in the code (I have to copy only the lines with the drop down list displays (complete), actually it's filled with 3 options (complete/cancel/in process)
Sub copier()
Dim ws1 As Worksheet, ws2 As Worksheet, src As Range, dest As Range, i As Integer
Set ws1 = Worksheets("Workload - Charge de travail")
Set ws2 = Worksheets("Sheet1")
For i = 2 To ws1.UsedRange.Rows.Count
Set src = ws1.Range("A2" & i & ":AG10" & i)
Set dest = ws2.Range("A2" & i & ":AG10" & i)
If Source.Cells(1, 4).Value = "complete" Then
src.Copy Destination:=dest
dest.Value = dest.Value
Next i
End If
End Sub
Here some changes to your code that might help.
Sub copier()
Dim ws1 As Worksheet, ws2 As Worksheet, src As Range, dest As Range, i As Integer
Set ws1 = Worksheets("Workload - Charge de travail")
Set ws2 = Worksheets("Sheet1")
For i = 2 To ws1.Range("A1").SpecialCells(xlLastCell).Row
' this is more reliable than the method you used (which relies ont eh workbook being saved)
' but there must be no gaps in column A.
' Your code would not work. Think about whay happens as i increases!
' ws1.Range("A2" & i & ":AG10" & i)
Set src = ws1.Range("A" & i & ":AG" & i+10 )
Set dest = ws2.Range("A" & i & ":AG" & i+10 )
If Source.Cells(1, 4).Value = "complete" Then
' what is source?
' What is this trying to do! I think you mean i+1 not 1.
' I think you mean src not source. I'm not psychic.
src.Copy Destination:=dest
dest.Value = dest.Value
End If
Next i
End Sub

Copy sheet data to the end of another sheet

I am able to copy the last row of one workbook and paste it after the last row of another workbook. I want to copy the entire data from row 2 (row 1 is header) in the first workbook and paste it after the last row of another workbook. Please advise me what changes are required in the code below to copy the entire data from row 2 instead of only the last row.
Dim lastS1Row As Long
Dim nextS2Row As Long
Dim lastCol As Long
Dim lCol As Long
Dim lCol1 As Long
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
lastS1Row = s1Sheet.Range("A" & Rows.Count).End(xlUp).Row
nextS2Row = s2Sheet.Range("A" & Rows.Count).End(xlUp).Row + 1
lastCol = s1Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
For lCol = 1 To lastCol
s2Sheet.Cells(nextS2Row, lCol) = s1Sheet.Cells(lastS1Row, lCol)
Next lCol
Next lCol1
s2Sheet.Activate
ActiveWorkbook.Close SaveChanges:=True
s1Sheet.Activate
ActiveWorkbook.Close
This adjusted version of your code should do the job:
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
Dim rngSource As Range
Dim rngTargetStart As Range
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
Set rngSource = Range(s1Sheet.Range("A2"), s1Sheet.Cells.SpecialCells(xlCellTypeLastCell))
Set rngTargetStart = s2Sheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
rngTargetStart.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
s2Sheet.Parent.Close SaveChanges:=True
s1Sheet.Parent.Close
I removed something what seemed unnecessary. The main thing is that now you don't loop through columns and rows. Now you can do it with one operation.
Avoid as much as you can things like .Select, .Activate. and .Copy if you just need values to be pasted. You can simply do something similar like I did:
Target.Value = Source.Value
After you set s1Sheet and s2Sheet I think you should be able to use these 2 lines to copy & paste the entire range at once:
'copy Cells A2 through last row and last column used
s1Sheet.Range(s1Sheet.Cells(2, 1), s1Sheet.Cells(s1Sheet.Cells(s1Sheet.Rows.Count, 1).End(xlUp).Row, _
s1Sheet.Cells(1, s1Sheet.Columns.Count).End(xlToLeft).Column)).Copy
'paste those cells in next blank row of second sheet
s2Sheet.Cells(s2Sheet.Cells(s2Sheet.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
'Here you go:
Range("A2").End(xlDown).select
selection.End(xlRight).select
selection.copy
'then active the next sheet for e.g Sheet2.Active
last_row = range("A1048576").end(xlup).row
range("A" & last_row).paste
' Done

VBA Copy ID's from one worksheet if no match is made

I do not have 10 reputation, so I'm unable to uploaded images, which would make this much, MUCH easier to explain... i posted a table example over to Mr. Excel forum here: http://www.mrexcel.com/forum/excel-questions/833202-visual-basic-applications-find-non-match-criteria-ws2-copy-criteria-ws1.html
I have two worksheets. I need to find Employee ID's in "Sheet2" that match the Employee ID's in "Sheet1". If "Sheet2" has an ID that is not in "Sheet1", then I need to copy specific cells from the said row of "Sheet2" over to "Sheet1".
On top of that, when copying over, I need to make sure that a whole row inserts for the copied cells in order for the previous $amounts to be in the correct spot (see the post in Mr. Excel). This probably makes no sense. If only I could upload an image...
Option Explicit
Sub CopyNonMatches()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1Range As Range, ws2range As Range
Dim ws1Long As Long, ws2long As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws1
ws1Long = .Range("C" & .Rows.Count).End(xlUp).Row
End With
Set ws1Range = ws1.Range("C3", "C" & ws1Long)
With ws2
ws2long = .Range("C" & .Rows.Count).End(xlUp).Row
End With
Set ws2range = ws2.Range("C3", "C" & ws2long)
'Now I need to compare the ranges 'ws1Range' with 'ws2Range' and if 'ws2Range' has ID's that...
'...are not included in 'ws1Range', then I need to copy over info from Columns A to C from the row that had no match over to 'Sheet1'.
???????????????????
End Sub
Sub CopyNonMatches()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim vIDs1 As Variant, vData As Variant
Dim i As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
vIDs1 = ws1.Range("C2", ws1.Range("C" & Rows.Count).End(xlUp)).Value
vData = ws2.Range("A2", ws2.Range("C" & Rows.Count).End(xlUp)).Value
For i = 1 To UBound(vData, 1)
If IsError(Application.Match(vData(i, 3), vIDs1, 0)) Then
ws1.Rows(8).Insert
ws1.Range("A8:C8").Value = Array(vData(i, 1), vData(i, 2), vData(i, 3))
End If
Next i
End Sub