Jul 01 2020 09:25 AM - edited Jul 01 2020 12:43 PM
Hi,
I've found this VBA code to transfer select data (Row 12 only) from one file (Source file) to another (Transfer Data file). Obviously, this is very limited in its uses, therefore i would like to adapt so that rather than transferring data from only Row 12 it transfers rows with 'Yes' in column A.
Currently, the VBA opens, adds the data to the 'Transfer Data' file on the next empty line, saves and closes the document. These features i'd like to remain.
Private Sub CommandButton1_Click()
Dim wb As Workbook
ThisWorkbook.Worksheets("Source").Rows(12).Select
Selection.Copy
Set wb = Workbooks.Open("C:\Users\Sslack\Desktop\Transfer Data.xlsx")
wb.Worksheets("data").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close savechanges = True
Set wb = Nothing
ThisWorkbook.Worksheets("Source").Activate
ThisWorkbook.Worksheets("Source").Cells(1, 1).Select
Application.CutCopyMode = False
End Sub
If anyone can assist it would be a huge help.
Thanks
Simon
Jul 02 2020 03:43 PM - edited Jul 02 2020 03:44 PM
Hi,
Please try the updated macro in the attached file. I used autofilter to select only data with 'Yes' in column A.
As your code saves the workbook before closing, I'd suggest saving a copy of both files to a new location (as a backup) before running the macro.
Jul 06 2020 09:29 AM
Hi @Charla74,
Thank you for the response.
I've just tried the macro and it returns the same result (Row 12). Maybe i've missed something? I've check the code and it looks to be the same too.
Thanks
Jul 06 2020 09:58 AM
Hi @Si_Slack
Did you download the file from my post? Anyway, the revised code should look as follows:
Private Sub CommandButton1_Click()
Dim wb As Workbook
ThisWorkbook.Worksheets("Source").Rows(12).Select
Selection.Copy
Set wb = Workbooks.Open("C:\Users\Sslack\Desktop\Transfer Data.xlsx")
wb.Worksheets("data").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close savechanges = True
Set wb = Nothing
ThisWorkbook.Worksheets("Source").Activate
ThisWorkbook.Worksheets("Source").Cells(1, 1).Select
Application.CutCopyMode = False
End Sub
Jul 08 2020 01:33 PM
Hi @Charla74,
Yes, I've downloaded the workbook a couple of times and tried it. It still only transfers 'Row 12' as it did previously.
Also, the code in your message is the same code i had in the original workbook.
Maybe the changes didn't save?
Jul 08 2020 01:40 PM
Solution
Oops! You're right, it is the same as the original, not sure how I managed that....
So, below should be the alternative code - try this and let me know how it works out for you.
Sub Export_Details()
Dim wb As Workbook
Dim rTable As Range
ThisWorkbook.Worksheets("Source").Activate
ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:="Yes"
Set rTable = Sheets("Source").AutoFilter.Range
Set rTable = rTable.Resize(rTable.Rows.Count - 1)
Set rTable = rTable.Offset(1)
rTable.Copy
Set wb = Workbooks.Open("C:\Users\Sslack\Desktop\Transfer Data.xlsm")
wb.Worksheets("data").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close savechanges = True
Set wb = Nothing
ThisWorkbook.Worksheets("Source").Activate
Application.CutCopyMode = False
ActiveSheet.AutoFilterMode = False
ThisWorkbook.Worksheets("Source").Cells(1, 1).Select
End Sub
Jul 10 2020 08:11 AM
@Charla74 It works a treat!! Thank you for your help!!
Jul 08 2020 01:40 PM
Solution
Oops! You're right, it is the same as the original, not sure how I managed that....
So, below should be the alternative code - try this and let me know how it works out for you.
Sub Export_Details()
Dim wb As Workbook
Dim rTable As Range
ThisWorkbook.Worksheets("Source").Activate
ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:="Yes"
Set rTable = Sheets("Source").AutoFilter.Range
Set rTable = rTable.Resize(rTable.Rows.Count - 1)
Set rTable = rTable.Offset(1)
rTable.Copy
Set wb = Workbooks.Open("C:\Users\Sslack\Desktop\Transfer Data.xlsm")
wb.Worksheets("data").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close savechanges = True
Set wb = Nothing
ThisWorkbook.Worksheets("Source").Activate
Application.CutCopyMode = False
ActiveSheet.AutoFilterMode = False
ThisWorkbook.Worksheets("Source").Cells(1, 1).Select
End Sub