SOLVED

VBA - Transferring select data to new spreadsheet

Copper Contributor

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

6 Replies

@Si_Slack 

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.

 

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

 

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

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?

best response confirmed by Si_Slack (Copper Contributor)
Solution

@Si_Slack 

 

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

@Charla74  It works a treat!! Thank you for your help!!

1 best response

Accepted Solutions
best response confirmed by Si_Slack (Copper Contributor)
Solution

@Si_Slack 

 

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

View solution in original post