Forum Discussion

Copper Contributor

Jul 01, 2020

Solved

VBA - Transferring select data to new spreadsheet

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 t...

Source.xlsm23 KB

Transfer Data.xlsx9 KB

excel

Formulas and Functions

Macros and VBA

Charla74
Jul 08, 2020
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

Si_Slack

Copper Contributor

Jul 06, 2020

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

Charla74

Iron Contributor

Jul 06, 2020

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

Si_Slack
Copper Contributor
Jul 08, 2020
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?
- Charla74
  Iron Contributor
  Jul 08, 2020
  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
  - Si_Slack
    Copper Contributor
    Jul 10, 2020
    Charla74 It works a treat!! Thank you for your help!!