Good morning all !
I m looking for a macro to copy/past a specific line of a global database at the end of an other excel, "client.xls".
I have find some solutions like this :
Sub transfert_data_fichier_client()
Dim Last_Row1 As Long, Last_Row2 As Long
Dim WB1 As Workbook, WB2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set WB1 = ThisWorkbook
Set ws1 = WB1.Sheets("Tri")
Set WB2 = Workbooks.Open("D:\Prospection\client.xlsx")
Set ws2 = WB2.Sheets("Feuil1")
Last_Row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("A3:H" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
ws1.Range("A3:H" & Last_Row1).Copy
ws2.Range("A" & Last_Row2).PasteSpecial Paste:=xlPasteValues
End Sub
But it is too limited, I don't want to enter in code for each copy/past.
I have imagined two solutions :
copy/past only a selected line;
to define a dynamic selection depending the row number, defined in a cell for example, like "Ai:H".
I have searched some applications but without success.
As I am a beginner in VBA, I m still limited. Which is the easiest way to do ?
Do you have some elements to help me ?
Have a good day !
Related
I am a trainee in a company and basically became tech support (better than coffee maker though)
And so i'm trying to get one closed workbook to copy data into an open one
So far this is the code i've got but i've some troubles with the if statement
Sub allergo()
Dim lastRow As Long
Dim bkBk1 As Workbook, wkBk2 As Workbook
Dim wkSht As Object
Dim mnt As String
lr = wkBk2.Sheets(1).Range("R" & Rows.Count).End(xlUp).Row
mnt = InputBox("Enter Filename")
Set wkBk1 = ActiveWorkbook
Set wkBk2 = Workbooks.Open("Documents\" & mnt & ".xlsx")
For Each cell In wkBk1.Sheets(1).Range(wkBk1.Sheets(1).Cells(2, "R"), wkBk1.Sheets(1).Cells(lr, "R"))
wkBk1.Sheets(1).Range("R1:R" & lr).Value = wkBk2.Sheets(1).Range("R1:R" & lastRow).Value
wkBk2.Close
End Sub
Basically I've got two files that have the same columns but between some weeks rows disapear or appear as each row is a purchase order with a specific number and in row R we add comments and i want the comments in column R to copy to the new work book on the row where there's the same purchase order number. While some comments are attached to purchase orders that are not in the file anymore so they are not needed and some purchase orders have moved so i can't just copy paste.
Not sure the If is a good idea as it won't compare my row E 146 with all the others of the new work book and thus only test E146 closed workbook = E146 newworkbook while it should test E146 closed = E147/E148 etc..
This is the closed workbook:
This is the new workbook:
Thanks for the help !
Maybe a VLOOKUP is possible for this kind of things i'm not sure ..
Sub strilltrying()
Dim ws As Worksheet
Set ws = Sheets("Sheet 1")
Dim lr As Long
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
Cells(lr, "R").Formula = "=VLOOKUP(E2,'H:\Documents\[OPEN ORDERS 16.07.2018.xlsx]Sheet 1'!$E:$R,14)"
End Sub
This is the vlookup formula that works but not fully as i've to take two different variables.. I found that index + match can do it but i'm having a hard time figuring it out.
I'd need an index formula that compares column E and column J in the way of the vlookup.
Sub allergo()
Dim lastRow As Long
Dim bkBk1 As Workbook, wkBk2 As Workbook
Dim wkSht As Object
Dim mnt As String
lr = wkBk2.Sheets(1).Range("R" & Rows.Count).End(xlUp).Row
mnt = InputBox("Enter Filename")
Set wkBk1 = ActiveWorkbook
Set wkBk2 = Workbooks.Open("Documents\" & mnt & ".xlsx")
For Each cell In wkBk1.Sheets(1).Range(wkBk1.Sheets(1).Cells(2, "R"), wkBk1.Sheets(1).Cells(lr, "R"))
if cell = "" then 'add your clause here
wkBk1.Sheets(1).Range("R1:R" & lr).Value = wkBk2.Sheets(1).Range("R1:R" & lastRow).Value
end if
next cell
wkBk2.Close
End Sub
Your requirements are not entirely clear, I would avoid a loop if possible as well.
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.
I'm currently trying to copy from one worksheet and paste into a new worksheet using VBA. however i have the following variables
The worksheet with data being copied is dynamic. the columns stay the same but the rows change every week.
The new worksheet which the data will be added to is dynamic. The Columns are the same but the new worksheet rows increase every week( e.g row 700 one week row 800 the next).
The columns (A and BC) that are being copied and pasted are consistent.
The data should be pasted on columns A- BC on the next available row
of the new worksheet
I've currently managed to come up with the following code but i keep getting error's and don't know where i am going wrong as i am new to VBA.
Sub CandP()
'
'
Dim Last_Row As Long
Application.ScreenUpdating = False
Last_Row = Range("A2:BC2" & Rows.Count).End(xlUp).Row
Range("A2:BC2").Copy
Windows("Newsheet.xlsm").Activate
Range("$A2:BC$" & last_row).FillDown
End Sub
All help is appreciated, Thank you
You could try this:
Option Explicit
Sub CandP()
Dim Last_Row1 As Long, Last_Row2 As Long
Dim WB1 As Workbook, WB2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set WB1 = ThisWorkbook ' Workbook where you want to copy the data
Set ws1 = WB1.Sheets("Sheet1") ' Change the name of your Sheet
Set WB2 = Workbooks.Open("C:\Desktop\vba\Newsheet.xlsm") ' Enter the address of the Workbook you want to paste the data
Set ws2 = WB2.Sheets("Sheet1") ' Change the name of your Sheet
Last_Row1 = ws1.Range("A" & Rows.Count).End(xlUp).Row ' Determine the lastrow of the data to copy
Last_Row2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1 ' Determine the next empty row in order to paste the data
ws1.Range("A2:BC" & Last_Row1).Copy ws2.Range("A" & Last_Row2)
End Sub
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!
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