vba to copy and paste file to each row of data

  • I have this loop that opens excel files on a SharePoint site adds the file name to column U in the destination file and all the other data starting in column A.

    I would like the script to copy the file name in all rows for each of the excel files on the destination file. This line below is where the file name gets added to only the first row found in column U

    SummarySheet.Range("U" & NRow).Value = FileName[/VBA]

    In the attachment "loop results.xlsx" you can see in column U only the first line in each file gets the file name populated. The other attachment "desired loop results.xlsx" is how I need the file name populated in column U

    [VBA]Sub PullDatafromSharepoint()

    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim NRow As Long
    Dim FileName As String
    Dim imgTitle As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    Dim FolderName As String
    Dim LR As Long
    Dim x As Long
    Dim n As Integer
    Dim temp As Long
    Dim rng As Range, ar As Range
    Dim nr As Range
    Dim mr As Range
    Dim LoginName As String
    Dim WinShuttle As Application
    Dim Connection As Object
    Dim session As Object
    Dim SAPApp As Object
    Dim SAPCon As Object, SAPSesi As Object
    Dim SAPGUIAuto As Object
    Dim sapConnection As Object
    Dim d As String, ext, y
    Dim SrRan As String
    Dim srcPath As String, destPath As String, srcFile As String
    Application.ScreenUpdating = False

    LoginName = UCase(GetUserID)

    'Designates Sheet for pasting from multiple workbooks
    Set SummarySheet = Worksheets(3)

    'Modify folder path when transferring between process owners
    FolderPath = "Z:\"

    'Nrow keeps track of where to insert new rows in the workbook
    NRow = 1
    'LR = ActiveSheet.Range("U" & Rows.Count).End(xlUp).Row
    'Call directory the first time pointing it to all excel files
    FileName = Dir(FolderPath & "*.xls*")
    'Loop until directory returns empty string
    Do While FileName <> ""
    'Open a workbook in the folder
    Set WorkBk = Workbooks.Open(FolderPath & FileName)

    'Set the cell in column U to house the file name
    SummarySheet.Range("U" & NRow).Value = FileName

    'Set the range to be A1000 through W1000
    On Error Resume Next
    Set SourceRange = WorkBk.Worksheets(1).Range("A2:M300")
    SrRan = Dir(FolderPath & "*.xls*")
    On Error GoTo 0
    'Set the destination range
    Set DestRange = SummarySheet.Range("A" & NRow)
    Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)

    'Copy over values from the source to the destination
    DestRange.Value = SourceRange.Value

    'Increase NRow so that data moves down
    NRow = NRow + DestRange.Rows.Count
    'Close source workbook
    WorkBk.Close SaveChanges:=False

    'Use Dir to get to the next file name
    FileName = Dir()

  • try moving the line like this

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!