Originally Posted by
Zack Barresse
Lightly tested...
[vba]Option Explicit
Private Const sWsName As String = "New Rating Layout"
Dim wbOrig As Workbook
Dim wbDest As Workbook
Dim wsOrig As Worksheet
Dim wsDest As Worksheet
Dim bOpen As Boolean
Dim bRanOK As Boolean
Dim vFile As Variant
Dim sName As String
Dim sPath As String
Dim sPrompt As String
Sub ImportData()
bRanOK = False
If WSEXISTS(sWsName, ThisWorkbook) = False Then
MsgBox "The worksheet '" & sWsName & "' does not exists in this file.", vbCritical, "ERROR!"
Exit Sub
End If
vFile = Application.GetOpenFilename("Import File (*.xls; *.xlsx; *.xlsm; *.xlsb), *.xls; *.xlsx; *.xlsm; *.xlsb")
If vFile = "False" Then Exit Sub
sName = Right(vFile, Len(vFile) - InStrRev(vFile, Application.PathSeparator))
sPath = Left(vFile, Len(vFile) - Len(sName))
Call TOGGLEEVENTS(False)
If WBISOPEN(sName) = True Then
Set wbOrig = Workbooks(sName)
bOpen = True
Else
Set wbOrig = Workbooks.Open(sPath & sName)
bOpen = False
End If
If WSEXISTS(sWsName, wbOrig) = False Then
sPrompt = "The worksheet '" & sWsName & "' in '" & sName & "' does not exist."
MsgBox sPrompt, vbCritical, "ERROR!"
GoTo ExitRoutine
End If
Set wsOrig = wbOrig.Worksheets(sWsName)
Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets(sWsName)
sPrompt = "Are you sure you want to clear the current '" & sWsName & "' worksheet and import new data? This cannot be undone."
If MsgBox(sPrompt, vbYesNo + vbDefaultButton2, "IMPORT?") <> vbYes Then GoTo ExitRoutine
wsDest.Cells.Clear
wsOrig.UsedRange.Copy
wsDest.Range("A1").PasteSpecial xlPasteAll
bRanOK = True
ExitRoutine:
If bOpen = False Then wbOrig.Close False
Call TOGGLEEVENTS(True)
Set wbDest = Nothing
Set wbOrig = Nothing
Set wsDest = Nothing
Set wsOrig = Nothing
If bRanOK = True Then
MsgBox "Import completed OK.", vbOKOnly, "FINISHED!"
End If
End Sub
Sub ExportData()
bRanOK = False
If WSEXISTS(sWsName, ThisWorkbook) = False Then
MsgBox "The worksheet '" & sWsName & "' does not exists in this file.", vbCritical, "ERROR!"
Exit Sub
End If
vFile = Application.GetSaveAsFilename(sWsName & ".xlsx", "Export File (*.xlsx), *.xlsx")
If vFile = "False" Then Exit Sub
sName = Right(vFile, Len(vFile) - InStrRev(vFile, Application.PathSeparator))
sPath = Left(vFile, Len(vFile) - Len(sName))
If LCase(Right(sName, 5)) <> ".xlsx" Then
MsgBox "You must save as an XLSX file type.", vbCritical, "ERROR!"
Exit Sub
End If
If Len(Dir(sPath & sName, vbNormal)) > 0 Then
MsgBox "That file name already exists.", vbCritical, "ERROR!"
Exit Sub
End If
On Error GoTo ErrHandle
Call TOGGLEEVENTS(False)
Set wbOrig = ThisWorkbook
Set wsOrig = wbOrig.Worksheets(sWsName)
Set wbDest = Workbooks.Add(xlWBATWorksheet)
Set wsDest = wbDest.Worksheets(1)
wsDest.Name = sWsName
wsOrig.UsedRange.Copy
wsDest.Range("A1").PasteSpecial xlPasteAll
wbDest.SaveAs sPath & sName, 51
bRanOK = True
ErrHandle:
Call TOGGLEEVENTS(True)
If bRanOK = True Then
MsgBox "Export completed OK.", vbOKOnly, "FINISHED!"
End If
End Sub
Public Function WBISOPEN(wkbName As String) As Boolean
On Error Resume Next
WBISOPEN = CBool(Workbooks(wkbName).Name <> "")
On Error GoTo 0
End Function
Public Function WSEXISTS(wksName As String, Optional WKB As Workbook) As Boolean
If WKB Is Nothing Then
If ActiveWorkbook Is Nothing Then Exit Function
Set WKB = ActiveWorkbook
End If
On Error Resume Next
WSEXISTS = CBool(WKB.Worksheets(wksName).Name <> "")
On Error GoTo 0
End Function
Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by Zack Barresse
With Application
If Not blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationManual
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState Then .CutCopyMode = False
If blnState Then .StatusBar = False
If blnState And Not ActiveWorkbook Is Nothing Then .Calculation = xlCalculationAutomatic
End With
End Sub[/vba]
Code must go into your 'master' workbook in a standard module.
HTH
Macro to import/export data
Reply With Quote
