VBA to Transfer (Certain) Data from One Workbook to Another

[nc_waggoner]

PLEASE HELP! I will describe this as detailed as possible.

GOAL: To auto-transfer data (criteria based/no blanks) from an online-based Sharepoint file to a separate workbook for analysis

From (Source) File = “LabData.xlsx” located online at http://sharepoint.com/Labs/LabData (made up)

To (Analysis) File = “LabData Analysis.xlsx”

THINGS TO CONSIDER:

1. Due to user/input error, only valid data should be transferred. No blanks with the best method being a named range…in the below example only transfer rows where the “DIFF” is between -3 and 3.
2. Preferred, but optional, to auto-open the source file from online so that I can do everything locally.

DATA EXAMPLE: (In the below example, samples 1, 6, and 10 should be omitted from the transfer for not meeting the criteria )

DATE	SAMPLE	TANK	TEST 1	SAMPLE WT	TEST 2	DIFF
8/1/2016	1	30	35	1.25	31.5	3.5
8/2/2016	2	40	30.5	2	33	-2.5
8/3/2016	3	50	31.5	1.75	32	-0.5
8/4/2016	4	1	32.5	1	34	-1.5
8/5/2016	5	10	33.5	2	33	0.5
8/6/2016	6	1	30.5	1		30.5
8/7/2016	7	10	31.5	2	33	-1.5
8/8/2016	8	20	32.5	1.5	32	0.5
8/9/2016	9	30	33.5	1.25	34	-0.5
8/10/2016	10	40	30.5	1	34	-3.5

<tbody>
</tbody><colgroup><col><col><col><col><col><col span="2"></colgroup>

 

[alansidman]

Try this code:

Option Explicit


Sub MoveData()
'Copy to Master Spreadsheet
Dim lr As Long
Dim lrC As Long
Dim wbTarget As Workbook 'Master
Dim wbThis As Workbook  'Current Open Workbook
Dim strName As String 'Name for source sheet/target workbook
Dim thePath As String  'Path for Master Spreadsheet
Dim i As Long


    Application.ScreenUpdating = False


'set the current active workbook
    Set wbThis = ActiveWorkbook
'set the target workbook name
    strName = "labdataanalysis"
'set the path to the Comments Spreadsheet
'change thepath to your path for the file
    thePath = "C:\Users\Alan\Desktop\"
'open Master Spreadsheet
    Set wbTarget = Workbooks.Open(thePath & strName & ".xlsx")
'Activate the Target Workbook
    wbTarget.Activate
'activate source workbook
    wbThis.Activate
'find the last row in column A to determine the range to copy
    lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'clear any thing on the clipboard to mazimize available memory
    Application.CutCopyMode = False
'Determine rows to copy
    For i = 1 To lr
    'Find the last row in the target workbook
    lrC = wbTarget.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    If wbThis.Sheets("Sheet1").Range("G" & i) >= -3 And wbThis.Sheets("Sheet1").Range("G" & i) <= 3 Then
    Range("G" & i).EntireRow.Copy wbTarget.Sheets("sheet1").Range("A" & lrC + 1)
    End If
    Next i
'Clear the clipboard
    Application.CutCopyMode = False
    wbTarget.Save
    wbTarget.Close
    wbThis.Activate
    Application.ScreenUpdating = True
         
'clear memory
    Set wbTarget = Nothing
    Set wbThis = Nothing
    MsgBox "Data Transferred"
End Sub

Put the code in the source file labdata and give it an .xlsm extention. Note that you will have to change thepath variable to your path. I have not worked with sharepoint so I am unsure of what that would be. I tested using just my desktop as a target. Also check the spelling of both files to ensure that the code and the files are exactly the same. ie. spaces and capitalization