Update Cell if Source Workbook or Source Worksheet is Missing

R

reberryjr

Well-known Member
Joined
Mar 16, 2017
Messages
714
Office Version
  1. 365
Platform
  1. Windows
Ideally, if s or sD aren't found, I'd like to update the last cell in a range. I haven't been able to get that cell to update if s is missing. Thoughts?

VBA Code: 
Option Explicit
Sub ImportT()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim m As Workbook, s As Workbook
Dim mO As Worksheet, sD As Worksheet, mV As Worksheet
Dim fP As String, fN As String, fE As String
Dim mOLR As Long, sDLR As Long, mVLR As Long
Dim uDP As String

Set m = ThisWorkbook
Set mO = m.Sheets("Org Info")
Set mV = m.Sheets("Variables")

uDP = CreateObject("WScript.Shell").SpecialFolders("Desktop")
mVLR = mV.Range("L" & Rows.Count).End(xlUp).Row

fP = uDP & "\Import Files\"
fN = "Org T"
fN = Dir(fP & fN & "*.xlsx")

On Error GoTo MissingFile

If Len(Dir(fP & fN, vbDirectory)) > 0 Then

    Set s = Workbooks.Open(fP & fN)
    Set sD = s.Sheets("Data")
    
    'Removes filters from the working data if any exist.
    If mO.AutoFilterMode Then mO.AutoFilterMode = False
    
    'Unhides any columns and rows that may be hidden on the working data.
    With mO.UsedRange
        .Columns.EntireColumn.Hidden = False
        .Rows.EntireRow.Hidden = False
    End With
    
    mOLR = mO.Range("A" & Rows.Count).End(xlUp).Row
    
    sDLR = sD.Range("A" & Rows.Count).End(xlUp).Row
    
    With sD.Range("H2:H" & sDLR).Copy
        mO.Range("A" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("A2:G" & sDLR).Copy
        mO.Range("B" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("I2:M" & sDLR).Copy
        mO.Range("I" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("X2:X" & sDLR).Copy
        mO.Range("N" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("BI2:BI" & sDLR).Copy
        mO.Range("O" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CK2:CK" & sDLR).Copy
        mO.Range("T" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CL2:CL" & sDLR).Copy
        mO.Range("S" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CM2:CM" & sDLR).Copy
        mO.Range("R" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CN2:CN" & sDLR).Copy
        mO.Range("Q" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CO2:CO" & sDLR).Copy
        mO.Range("P" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("H2:H" & sDLR).Copy
        mO.Range("U" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("Y2:Y" & sDLR).Copy
        mO.Range("V" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("AA2:AA" & sDLR).Copy
        mO.Range("W" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    s.Close SaveChanges:=False

Else
    Err.Raise 53
    mV.Range("L" & mVLR + 1).Value = "Org-T"
End If

MissingFile:
'mV.Range("L" & mVLR + 1).Value = "Org-T"  ---  Is updating every import file.
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Sort by date Sort by votes
reberryjr said:
I'd like to update the last cell in a range
Click to expand...
reberryjr said:
that cell
Click to expand...

It is not clear which cell you are referring to, so I'm making some fairly wild guesses (Not tested).

VBA Code: 
Sub ImportT()
    
    Dim m As Workbook, s As Workbook
    Dim mO As Worksheet, sD As Worksheet, mV As Worksheet
    Dim fP As String, fN As String
    Dim mOLR As Long, sDLR As Long, mVLR As Long
    Dim uDP As String
    
    Set m = ThisWorkbook
    Set mO = m.Sheets("Org Info")
    Set mV = m.Sheets("Variables")
    
    uDP = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    mVLR = mV.Range("L" & Rows.Count).End(xlUp).Row
    
    fP = uDP & "\Import Files\"
    fN = "Org T"
    fN = Dir(fP & fN & "*.xlsx")
    
    If Len(Dir(fP & fN, vbDirectory)) = 0 Then
        MsgBox "Folder not found" & vbCr & vbCr & fP & fN
        GoTo MissingFile
    End If
    
    On Error Resume Next
    Set s = Workbooks.Open(fP & fN)
    Set sD = s.Sheets("Data")
    On Error GoTo 0
    
    If s Is Nothing Then
        MsgBox "Missing workbook"
        GoTo MissingFile
    End If
    
    If sD Is Nothing Then
        MsgBox "Missing worksheet"
        GoTo MissingFile
    End If
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'Removes filters from the working data if any exist.
    If mO.AutoFilterMode Then mO.AutoFilterMode = False
    
    'Unhides any columns and rows that may be hidden on the working data.
    With mO.UsedRange
        .Columns.EntireColumn.Hidden = False
        .Rows.EntireRow.Hidden = False
    End With
    
    mOLR = mO.Range("A" & Rows.Count).End(xlUp).Row
    
    sDLR = sD.Range("A" & Rows.Count).End(xlUp).Row
    
    With sD.Range("H2:H" & sDLR).Copy
        mO.Range("A" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("A2:G" & sDLR).Copy
        mO.Range("B" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("I2:M" & sDLR).Copy
        mO.Range("I" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("X2:X" & sDLR).Copy
        mO.Range("N" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("BI2:BI" & sDLR).Copy
        mO.Range("O" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CK2:CK" & sDLR).Copy
        mO.Range("T" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CL2:CL" & sDLR).Copy
        mO.Range("S" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CM2:CM" & sDLR).Copy
        mO.Range("R" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CN2:CN" & sDLR).Copy
        mO.Range("Q" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("CO2:CO" & sDLR).Copy
        mO.Range("P" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("H2:H" & sDLR).Copy
        mO.Range("U" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("Y2:Y" & sDLR).Copy
        mO.Range("V" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    With sD.Range("AA2:AA" & sDLR).Copy
        mO.Range("W" & mOLR + 1).PasteSpecial xlPasteValues
    End With
    
    s.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub
    
MissingFile:
    mV.Range("L" & mVLR + 1).Value = "Org-T"  '---  Is updating every import file.
End Sub
 
Upvote 0
Solution
rlv01 said:
It is not clear which cell you are referring to, so I'm making some fairly wild guesses (Not tested).

VBA Code: 
Sub ImportT()
   
    Dim m As Workbook, s As Workbook
    Dim mO As Worksheet, sD As Worksheet, mV As Worksheet
    Dim fP As String, fN As String
    Dim mOLR As Long, sDLR As Long, mVLR As Long
    Dim uDP As String
   
    Set m = ThisWorkbook
    Set mO = m.Sheets("Org Info")
    Set mV = m.Sheets("Variables")
   
    uDP = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    mVLR = mV.Range("L" & Rows.Count).End(xlUp).Row
   
    fP = uDP & "\Import Files\"
    fN = "Org T"
    fN = Dir(fP & fN & "*.xlsx")
   
    If Len(Dir(fP & fN, vbDirectory)) = 0 Then
        MsgBox "Folder not found" & vbCr & vbCr & fP & fN
        GoTo MissingFile
    End If
   
    On Error Resume Next
    Set s = Workbooks.Open(fP & fN)
    Set sD = s.Sheets("Data")
    On Error GoTo 0
   
    If s Is Nothing Then
        MsgBox "Missing workbook"
        GoTo MissingFile
    End If
   
    If sD Is Nothing Then
        MsgBox "Missing worksheet"
        GoTo MissingFile
    End If
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    'Removes filters from the working data if any exist.
    If mO.AutoFilterMode Then mO.AutoFilterMode = False
   
    'Unhides any columns and rows that may be hidden on the working data.
    With mO.UsedRange
        .Columns.EntireColumn.Hidden = False
        .Rows.EntireRow.Hidden = False
    End With
   
    mOLR = mO.Range("A" & Rows.Count).End(xlUp).Row
   
    sDLR = sD.Range("A" & Rows.Count).End(xlUp).Row
   
    With sD.Range("H2:H" & sDLR).Copy
        mO.Range("A" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("A2:G" & sDLR).Copy
        mO.Range("B" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("I2:M" & sDLR).Copy
        mO.Range("I" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("X2:X" & sDLR).Copy
        mO.Range("N" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("BI2:BI" & sDLR).Copy
        mO.Range("O" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("CK2:CK" & sDLR).Copy
        mO.Range("T" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("CL2:CL" & sDLR).Copy
        mO.Range("S" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("CM2:CM" & sDLR).Copy
        mO.Range("R" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("CN2:CN" & sDLR).Copy
        mO.Range("Q" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("CO2:CO" & sDLR).Copy
        mO.Range("P" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("H2:H" & sDLR).Copy
        mO.Range("U" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("Y2:Y" & sDLR).Copy
        mO.Range("V" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    With sD.Range("AA2:AA" & sDLR).Copy
        mO.Range("W" & mOLR + 1).PasteSpecial xlPasteValues
    End With
   
    s.Close SaveChanges:=False
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub
   
MissingFile:
    mV.Range("L" & mVLR + 1).Value = "Org-T"  '---  Is updating every import file.
End Sub
Click to expand...
The cell being updated is
VBA Code: 
mV.Range("L" & mVLR + 1).Value
. I already tried the solution you propose, and it updates the range for every file being imported, not the missing files.
 
Upvote 0
reberryjr said:
I already tried the solution you propose, and it updates the range for every file being imported, not the missing files.
Click to expand...

Did you used my code as posted, or did you make modifications yourself to match it? Because when I test it, it does not work that way. If s and sD ARE found, the range (mV.Range("L" & mVLR + 1).Value ) is not updated.
 
Upvote 0
rlv01 said:
Did you used my code as posted, or did you make modifications yourself to match it? Because when I test it, it does not work that way. If s and sD ARE found, the range (mV.Range("L" & mVLR + 1).Value ) is not updated.
Click to expand...
I have tried the code (w/o the message boxes). Both s and sD are present and
VBA Code: 
mV.Range("L" & mVLR + 1).Value
is still being updated.
 
Upvote 0
reberryjr said:
w/o the message boxes
Click to expand...

Sounds like you 'interpreted' the code I posted instead of running it as-is. My guess would be that yours is missing the critical Exit Sub statement.

VBA Code: 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Exit Sub '<--------------- Critical to preventing  mV.Range update when the file is found. 
    
MissingFile:
    mV.Range("L" & mVLR + 1).Value = "Org-T"  '---  Is updating every import file.
End Sub
 
Upvote 0
rlv01 said:
Sounds like you 'interpreted' the code I posted instead of running it as-is. My guess would be that yours is missing the critical Exit Sub statement.

VBA Code: 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
    Exit Sub '<--------------- Critical to preventing  mV.Range update when the file is found.
   
MissingFile:
    mV.Range("L" & mVLR + 1).Value = "Org-T"  '---  Is updating every import file.
End Sub
Click to expand...
I wouldn't say I "interpreted" it, but I did try to adapt it to omit the message boxes. In doing so, your assumption is correct...I was missing the Exit Sub. I thank you for your assistance and your patience.
 
Upvote 0
No worries. Glad you have everything working now.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Filter & Delete Deleting Header Row Suddenly
Replies
0
Views
457
reberryjr
R
R
  • Solved
VBA Find & Replace Not Finding
2
Replies
19
Views
1K
Joe4
Joe4
R
  • Question Question
Whole Worksheet being Copied Instead of Desired Range
Replies
0
Views
243
reberryjr
R
R
  • Question Question
Error Handling Missing Files in Import Process
Replies
1
Views
378
rlv01
R
R
  • Question Question
Scripting Dictionary Kicking my Behind
Replies
1
Views
378
Legacy 143009
L

Forum statistics

Threads
1,223,889
Messages
6,175,223
Members
452,620
Latest member
dsubash

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top