I've added more error handling in case someone with less knowledge of Excel is using it.
I've also added a Sheet Name cell (J40) so you can copy a different sheet if required (and cope with future years!).
In Sheet1(Master) module:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim calc As Long
With Application
.ScreenUpdating = False
If .Intersect(Target, Range("C42:C48")) Is Nothing Then Exit Sub
calc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
If Target.Row <> 48 Then
ImportXL Cells(Target.Row, "D"), Target.Value2, Range("J40")
Else
ImportAllXL
End If
.DisplayAlerts = True
.Calculation = calc
End With
End Sub
Note: Application.ScreenUpdating does not need to be set to true on exit, Excel defaults to this after the routine is run.
In mdKed_Routines module:
Option Explicit
Sub ImportXL(fPath As String, wk As String, shName As String)
On Error GoTo Oops
Dim ex As String, str As String, sh As Worksheet, sht As Long, ct As Long
'Check if Sheet Name has been entered
If Range("J40") = "" Then MsgBox "No Sheet Name in J40!", vbCritical, "Please provide a sheet name...": Exit Sub
'Check if File Name has been entered
If Range("D40") = "" Then MsgBox "No File Name in D40!", vbCritical, "Please provide a file name...": Exit Sub
'Check if file exists
ex = fPath & "\" & Range("D40") & Right(fPath, 11) & ".xlsm"
If Len(Dir(ex)) = 0 Then
MsgBox "File:" & vbLf & ex & vbLf & "could not be found!", vbCritical, "No file available..."
Exit Sub
End If
'Show progress
frmWrk.lb1 = "Opening file..."
frmWrk.lb2 = ex
frmWrk.Show
Application.StatusBar = "Copying " & ex & " data..."
DoEvents
'Open file
Workbooks.Open fPath & "\" & Range("D40") & Right(fPath, 11) & ".xlsm", UpdateLinks:=0
'Show progress
frmWrk.lb1 = "Copying data from..."
DoEvents
Eto1:
'Copy Sheet
If wk = "Start of the Month" Then
ThisWorkbook.Sheets("Data SOM").Cells.ClearContents
If ct = 0 Then ActiveWorkbook.Sheets(shName).Cells.Copy
If ct > 0 Then ActiveWorkbook.Sheets(sht).Cells.Copy
ThisWorkbook.Sheets("Data SOM").Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ThisWorkbook.Sheets("Data SOM").Range("A1").PasteSpecial Paste:=xlPasteFormats
Else
ThisWorkbook.Sheets("Data " & wk).Cells.ClearContents
If ct = 0 Then ActiveWorkbook.Sheets(shName).Cells.Copy
If ct > 0 Then ActiveWorkbook.Sheets(sht).Cells.Copy
ThisWorkbook.Sheets("Data " & wk).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ThisWorkbook.Sheets("Data " & wk).Range("A1").PasteSpecial Paste:=xlPasteFormats
End If
'Close file
ActiveWorkbook.Close 0
NormXit:
'Tidy up and exit
ThisWorkbook.Sheets("Master").Activate
Application.StatusBar = False
Application.CutCopyMode = False
frmWrk.Hide
Exit Sub
Oops:
'If error isn't Subscript out of Range, exit
If Err.Number <> 9 Then MsgBox "Error " & Err.Number & " occurred." & vbLf _
& Err.Description, vbCritical, "Oops! Error...": Exit Sub
'Reset error
On Error GoTo -1
'Assume sheet not present for error 9
'Build string of sheets
ct = 1
str = "You can choose another sheet by NUMBER." & vbLf & "If you don't want any to load, leave at zero." _
& vbLf & "Sheets in this workbook:" & vbLf & vbLf
For Each sh In ActiveWorkbook.Worksheets
str = str & ct & ". " & sh.Name & vbLf
ct = ct + 1
Next
str = str & vbLf & vbLf & "NUMBER of the spreadsheet to load (zero = Exit)."
Eto2:
On Error GoTo Err2
'Get alternative sheet
sht = InputBox(str, "Sheet " & shName & " not found...", 0)
'Check sheet number is valid
If sht > ct Then
MsgBox "Sheet doesn't exist!!!!", vbCritical, "Read the info..."
GoTo Eto2
End If
'Exit as requested
If sht = 0 Then GoTo NormXit
'Try again
GoTo Eto1
Err2:
'Reset error
On Error GoTo -1
'String entered in inputbox
MsgBox "It has to be a number!!!!", vbCritical, "Read the info..."
GoTo Eto2
End Sub
Sub ImportAllXL()
Dim i As Long
For i = 42 To 47
If Cells(i, 4) <> "" Then ImportXL Cells(i, 4), Cells(i, 3), Range("J40")
Next
End Sub