Option Explicit
Sub LogNewTags()
' check daily work request file for any new records not yet sucessfuly logged
' add new records to master file
Dim vDailyData As Variant, vMasterData As Variant
Dim lDailyRwIdx As Long, lLastRw As Long, lNextCol As Long
Dim lMasterRwIdx As Long, bFound As Boolean, lMatched As Long, lUnmatched As Long, rTarget As Range
Dim WbMasterData As Workbook, WbDailyData As Workbook, WsMasterData As Worksheet, WsDailyData As Worksheet
' master file name and path
Const cWbMasterDataName = "SBR Historical Trend (Master).xls"
Const cWBMasterDataPath = "H:\"
' check daily Work Request File is open/active
If Trim(ActiveSheet.Range("A1").Value) <> "Instrument Daily Work Request" Then
MsgBox "Daily Work Request File must open and displayed (active workbook) to update to master" & vbLf & vbLf & _
"Open Daily Work Request File, then and re-run this tool", vbOKOnly, "File not displayed"
Exit Sub
ElseIf ActiveSheet.Parent.ReadOnly = True Then
MsgBox "The ActiveWorkbook (" & ActiveWorkbook.Name & ") is currently open as Read Only, so any updates can not be saved" & vbLf & vbLf & _
"Close the Workbook then and re-run this tool", vbOKOnly, "File open Read Only"
Exit Sub
Else
Set WbDailyData = ActiveWorkbook
End If
' capture new data
For Each WsDailyData In WbDailyData.Sheets
With WsDailyData
' check if valid sheet and not future dated
If Trim(.Range("A1").Value) = "Instrument Daily Work Request" And _
.Range("e3").Value < Date Then
lLastRw = .Cells(.Rows.Count, "B").End(xlUp).Row
If lLastRw > 9 Then
For lMasterRwIdx = 10 To lLastRw
If .Cells(lMasterRwIdx, "B").Value <> "" And .Cells(lMasterRwIdx, "F").Value <> "Logged" Then
If Not IsArray(vDailyData) Then
ReDim vDailyData(1 To 3, 1 To 1)
Else
ReDim Preserve vDailyData(1 To 3, 1 To UBound(vDailyData, 2) + 1)
End If
Set vDailyData(1, UBound(vDailyData, 2)) = .Cells(lMasterRwIdx, "F") ' logged cell
vDailyData(2, UBound(vDailyData, 2)) = .Cells(lMasterRwIdx, "B").Value
vDailyData(3, UBound(vDailyData, 2)) = "Dt: " & .Range("e3").Value & vbLf & _
"Trb: " & .Cells(lMasterRwIdx, "C").Value & vbLf & _
"WCO: " & .Cells(lMasterRwIdx, "D").Value
End If
Next lMasterRwIdx
End If
End If
End With
Next
If Not IsArray(vDailyData) Then
MsgBox "No new Daily Work Request data found to log to master", vbOKOnly, "No New Updates to Log"
GoTo DoExit
End If
' check and capture daily data
If HasFileAccess(cWBMasterDataPath) = False Then
MsgBox "You do not have access to open or save the " & cWBMasterDataPath & " workbook to path " & cWBMasterDataPath & _
vbLf & vbLf & "This must be resolved before you can continue", vbOKOnly, "No access to file"
Exit Sub
ElseIf IsWorkbookOpenByMe(cWbMasterDataName) = True Then
If Workbooks(cWbMasterDataName).ReadOnly = True Then
MsgBox "Workbook " & cWbMasterDataName & " is currently open as Read Only, so any data additions can not be saved" & vbLf & vbLf & _
"Close the Workbook " & cWbMasterDataName & " then and re-run this tool", vbOKOnly, "File open Read Only"
Exit Sub
Else
Set WbMasterData = Workbooks(cWbMasterDataName)
End If
ElseIf IsFileAlreadyOpen(cWBMasterDataPath & "\" & cWbMasterDataName) = True Then
MsgBox "The Workbook " & cWbMasterDataName & " is currently open by another user." & vbLf & vbLf & _
"When Workbook " & cWbMasterDataName & " is available, re-run this tool", vbOKOnly, "File open by another user"
Exit Sub
Else
On Error GoTo FileError1
Set WbMasterData = Workbooks.Open(cWBMasterDataPath & "\" & cWbMasterDataName)
On Error GoTo 0
End If
' capture all Master Data tags
For Each WsMasterData In WbMasterData.Sheets
With WsMasterData
lLastRw = .Cells(.Rows.Count, "B").End(xlUp).Row
If lLastRw > 1 Then
For lMasterRwIdx = 2 To lLastRw
If .Cells(lMasterRwIdx, "A").Value <> "" And .Cells(lMasterRwIdx, "B").Value <> "" And .Cells(lMasterRwIdx, "C").Value <> "" Then
If Not IsArray(vMasterData) Then
ReDim vMasterData(1 To 2, 1 To 1)
Else
ReDim Preserve vMasterData(1 To 2, 1 To UBound(vMasterData, 2) + 1)
End If
Set vMasterData(1, UBound(vMasterData, 2)) = .Cells(lMasterRwIdx, "A")
vMasterData(2, UBound(vMasterData, 2)) = .Cells(lMasterRwIdx, "A").Value
End If
Next lMasterRwIdx
End If
End With
Next
Application.ScreenUpdating = False
' now loop through new daily tags and add to master
For lDailyRwIdx = LBound(vDailyData, 2) To UBound(vDailyData, 2)
bFound = False
For lMasterRwIdx = LBound(vMasterData, 2) To UBound(vMasterData, 2)
If vDailyData(2, lDailyRwIdx) = vMasterData(2, lMasterRwIdx) Then
bFound = True
vDailyData(1, lDailyRwIdx).Value = "Logged"
Set rTarget = vMasterData(1, lMasterRwIdx)
With rTarget
lNextCol = .Cells(1, .Parent.Columns.Count).End(xlToLeft).Column + 1
With .Cells(1, lNextCol)
.Value = vDailyData(3, lDailyRwIdx)
.ColumnWidth = 200
.EntireRow.AutoFit
.EntireColumn.AutoFit
End With
End With
Exit For
End If
Next lMasterRwIdx
If bFound = False Then
vDailyData(1, lDailyRwIdx).Value = "Invalid Equipment Tag"
lUnmatched = lUnmatched + 1
Else
lMatched = lMatched + 1
End If
Next lDailyRwIdx
Application.ScreenUpdating = True
' save updates
WbDailyData.Save
If lMatched > 0 Then WbMasterData.Save
' done
MsgBox lMatched & " records appended to master file" & _
IIf(lUnmatched > 0, vbLf & vbLf & lUnmatched & _
" unmatched records could not be appended to master file " & vbLf & _
"(possibly invalid equipment tags in daily file or missing equipment tags in master file)" & vbLf & _
"Refer daily file records marked as ""Invalid Equipment Tag""", ""), _
vbOKOnly, "Logging To Master Completed"
DoExit:
On Error Resume Next
Set WbMasterData = Nothing
Set WbDailyData = Nothing
Set rTarget = Nothing
Erase vDailyData
Erase vMasterData
On Error GoTo 0
Exit Sub
FileError1:
MsgBox "An error ocurred when attempting to open workbook " & cWbMasterDataName, vbOKCancel, "File Open Error"
GoTo DoExit
End Sub
Function IsFileAlreadyOpen(FullFileName As String) As Boolean
'The function returns True if you can't get full access to the file.
Dim F As Integer
F = FreeFile
On Error Resume Next
Open FullFileName For Binary Access Read Write Lock Read Write As #F
Close #F
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
IsFileAlreadyOpen = True
Err.Clear
Else
IsFileAlreadyOpen = False
End If
On Error GoTo 0
End Function
Function IsWorkbookOpenByMe(WorkBookName As String) As Boolean
' returns TRUE if the current user has workbook open
IsWorkbookOpenByMe = False
On Error GoTo WorkBookNotOpen
If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
IsWorkbookOpenByMe = True
Exit Function
End If
WorkBookNotOpen:
On Error GoTo 0
End Function
Function HasFileAccess(sPath As String) As Boolean
' validate if user has drive/folder write access to folder
Dim iFileHandle As Integer
Dim sFolderPath As String
On Error GoTo ErrTrap
sFolderPath = Trim(sPath)
If Right(sFolderPath, 1) <> "\" Then
sFolderPath = sFolderPath & "\"
End If
sFolderPath = sFolderPath & Environ("Username") & "_Test_For_Write_Access.txt"
iFileHandle = FreeFile
Open sFolderPath For Output As iFileHandle
Close #iFileHandle
Kill sFolderPath
HasFileAccess = True
Exit Function
ErrTrap:
HasFileAccess = False
End Function
Bookmarks