T
trumb1mj
I currently I am working on a dashboard type project for work. I have
been able to pull .xls files from other folders through different
paths, the problem is that I need to be able to get files from a
password protected directory on a remote computer. Is this possible?
Any help would be great. Here is my current code:
Sub Update500()
'Stops screen flashes
Application.ScreenUpdating = False
'Selects and clears range
Range("A1").Select
Range("A3:E5000").Select
Selection.ClearContents
Dim wbResult As Workbook
Dim wbSource As Workbook
Dim MyFolder As String
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim Dest As Range
Dim i As Integer
'Selects folder that will be searched
MyFolder = "\\wk500\c\QA\TestCases"
Set wbResult = ThisWorkbook
'Selects destination worksheet
Set Dest = wbResult.Sheets("Dashboard").[a2]
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Application.FileSearch
..NewSearch
..LookIn = MyFolder
..FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
'Selects test case file from folder
Set wbSource = Workbooks.Open(Filename:=.FoundFiles(i),
UpdateLinks:=0)
Application.StatusBar = "It's Updating " & wbSource.Name & " Pl.
Wait...."
'Unhides input cells
Columns("S:X").Select
Selection.EntireColumn.Hidden = False
'Adds filename to intput cells
Range("T3") = ActiveWorkbook.Name
'Selects and copies input cells
Range("T3:X3").Select
Selection.Copy
'Says that file has been saved
ActiveWorkbook.Saved = True
Application.DisplayAlerts = False
'Closes test case
ActiveWindow.Close
'Activates dashboard and selects cells
Windows("dashboard.xls").Activate
Range("A1:E1").Select
'Selects last filled cells and moves one row below
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
'Pastes input cells
ActiveSheet.paste
'Moves to next test case file
Next i
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.StatusBar = False
'Notifies user that update is complete
MsgBox "All tests have been updated into the Dashboard!", , "Update
Complete"
End Sub
been able to pull .xls files from other folders through different
paths, the problem is that I need to be able to get files from a
password protected directory on a remote computer. Is this possible?
Any help would be great. Here is my current code:
Sub Update500()
'Stops screen flashes
Application.ScreenUpdating = False
'Selects and clears range
Range("A1").Select
Range("A3:E5000").Select
Selection.ClearContents
Dim wbResult As Workbook
Dim wbSource As Workbook
Dim MyFolder As String
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim Dest As Range
Dim i As Integer
'Selects folder that will be searched
MyFolder = "\\wk500\c\QA\TestCases"
Set wbResult = ThisWorkbook
'Selects destination worksheet
Set Dest = wbResult.Sheets("Dashboard").[a2]
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Application.FileSearch
..NewSearch
..LookIn = MyFolder
..FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
'Selects test case file from folder
Set wbSource = Workbooks.Open(Filename:=.FoundFiles(i),
UpdateLinks:=0)
Application.StatusBar = "It's Updating " & wbSource.Name & " Pl.
Wait...."
'Unhides input cells
Columns("S:X").Select
Selection.EntireColumn.Hidden = False
'Adds filename to intput cells
Range("T3") = ActiveWorkbook.Name
'Selects and copies input cells
Range("T3:X3").Select
Selection.Copy
'Says that file has been saved
ActiveWorkbook.Saved = True
Application.DisplayAlerts = False
'Closes test case
ActiveWindow.Close
'Activates dashboard and selects cells
Windows("dashboard.xls").Activate
Range("A1:E1").Select
'Selects last filled cells and moves one row below
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
'Pastes input cells
ActiveSheet.paste
'Moves to next test case file
Next i
End If
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.StatusBar = False
'Notifies user that update is complete
MsgBox "All tests have been updated into the Dashboard!", , "Update
Complete"
End Sub