Sub ChangePath()
Dim xName As String
Dim xPath As String
'Assumes folder path is under same name as Windows login
xName = Environ("USERNAME")
xPath = "C:\Users\" & xName & "\Desktop"
Application.Dialogs(xlDialogSaveAs).Show xPath
End Sub
Sub ChangePath()
'If path is known
Dim xPath As String
xPath = "C:\temp"
Application.Dialogs(xlDialogSaveAs).Show xPath
End Sub
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim LR As Long
Dim fPath As String
On Error Resume Next
'Where is the file of interest?
fPath = "\\ServerAddress\Data Backup\KT\Update\File2.xlsm"
Set wbSource = ThisWorkbook
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbDest = Workbooks.Open(fPath)
For Each wsSource In wbSource.Worksheets
With wsSource
Select Case .Name
Case "Home", "Data", "Master", "Metrics", "IntelliSense", "Dashboard", "SmartBoard", _
"YTDMetrics", "WeeklyReporting", "Pending Tasks", "Sheet7", "PPTWizard", "Share", _
"UpdateTab", "Sheet2", "Validate", "Calendar", "Instructions", "Location", "DataFeed", _
"FAQs", "Sheet1", "Version Control", "Reporting", "Welcome"
'Do nothing, ignore these sheets
Case Else
'Check if sheet exists
Set wsDest = Nothing
On Error Resume Next
Set wsDest = wbDest.Worksheets(.Name)
On Error GoTo 0
If Not wsDest Is Nothing Then
LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A21:A" & LR).EntireRow.Copy wsDest.Range("A21")
End If
End Select
End With
Next wsSource
'Save As will happen to the active workbook
wbDest.Activate
Application.Dialogs(xlDialogSaveAs).Show
wbDest.Close
Application.EnableEvents = True
Application.ScreenUpdating = True
Public Sub SaveFile()
Dim wbSource As Workbook, wbDest As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet
Dim strDirectoryPath As String, strfilename As String
Dim objShell As Object
Dim LR As Long
Dim fPath As String
On Error Resume Next
' Where is the file of interest?
fPath = "\\ServerAddress\Data Backup\KT\Update\File2.xlsm"
Set wbSource = ThisWorkbook
Set wbDest = Workbooks.Open(fPath)
strfilename = wbSource.Name
Set objShell = CreateObject("WScript.Shell")
strDirectoryPath = objShell.Specialfolders.Item("Desktop")
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each wsSource In wbSource.Worksheets
With wsSource
Select Case .Name
Case "Home", "Data", "Master", "Metrics", "IntelliSense", "Dashboard", "SmartBoard", _
"YTDMetrics", "WeeklyReporting", "Pending Tasks", "Sheet7", "PPTWizard", "Share", _
"UpdateTab", "Sheet2", "Validate", "Calendar", "Instructions", "Location", "DataFeed", _
"FAQs", "Sheet1", "Version Control", "Reporting", "Welcome"
' Do nothing, ignore these sheets
Case Else
' Check if sheet exists
Set wsDest = Nothing
On Error Resume Next
Set wsDest = wbDest.Worksheets(.Name)
On Error GoTo 0
If Not wsDest Is Nothing Then
LR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A21:A" & LR).EntireRow.Copy wsDest.Range("A21")
End If
End Select
End With
Next wsSource
' Save As will happen to the active workbook
wbDest.SaveAs strDirectoryPath & "\" & "Copy of " & strfilename, FileFormat:=52
wbDest.Close
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub