1 Attachment(s)
vba to copy and paste each file name
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 in column A:M.
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
Code:
SummarySheet.Range("U" & NRow).Value = FileName
I attached the results from the original script. I need column U to populate all rows with the filename for each workbook
Attachment 20723
Code:
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()
Loop
