Subroutine works but can it be improved?
I hope that the function of this routine is self expanatory. I am hacking as
best as I can but would like some insight on how this routine could be
improved.
Thanks in advance, Dean.
CopySheetValues(pFromFile As String, pFileStatus As String, pFromSheet As
String, pFromRange As String, pToSheet As String, pTextColumns As Long
'-----------------------------------------------------------------------------------'
' This routine will copy values in a named ranged from a spreadsheet tab
specified '
' in the parameters to a spreadsheet tab after clearing out the existing
data and '
' formatting the first n columns as text in ensure proper database
functions.
'-----------------------------------------------------------------------------------'
Dim i As Long
Dim basebook As Workbook
Dim basesheet As Worksheet
Dim baserangeold As Range
Dim baserangenew As Range
Dim frombook As Workbook
Dim fromsheet As Worksheet
Dim fromrange As Range
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = ASFilePath
.SearchSubFolders = False
.Filename = pFromFile
.FileType = msoFileTypeExcelWorkbooks
If .Execute() = 0 Then
Beep
MsgBox "Workbook " & pFromFile & " Not Found. Data Not Copied."
ElseIf .Execute() = 1 Then
If WorkbookOpen(pFromFile) Then
Set frombook = Workbooks(pFromFile)
Else
Set frombook = Workbooks.Open(.FoundFiles(1))
End If
Set basebook = ThisWorkbook
Set basesheet = basebook.Worksheets(pToSheet)
Set fromrange =
frombook.Worksheets(pFromSheet).Range(pFromRange)
Set baserangeold = basebook.Worksheets(pToSheet).UsedRange
With fromrange
Set baserangenew =
basebook.Worksheets(pToSheet).Cells(1, 1).Resize(.Rows.Count, .Columns.Count)
End With
baserangeold.ClearContents
basesheet.Activate
If pTextColumns < 0 Then
For i = 1 To pTextColumns
Columns(i).NumberFormat = "@"
Next i
End If
baserangenew.Value = fromrange.Value
If pFileStatus = "Close" Then
frombook.Close
End If
Else
Beep
MsgBox "Multiple Workbooks Found. Data Not Copied."
End If
End With
Set basebook = Nothing
Set basesheet = Nothing
Set baserangeold = Nothing
Set baserangenew = Nothing
Set frombook = Nothing
Set fromsheet = Nothing
Set fromrange = Nothing
Application.DisplayAlerts = True
End Sub
|