Option Explicit
Sub AddNewClaims()
If Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row = 1 Then
MsgBox "There are no new claims to be transferred!!", vbExclamation, "Transfer Claim Data Editor"
Exit Sub
End If
'Save a Backup
Dim relativePath As String
relativePath = ThisWorkbook.Path & "\" & ActiveWorkbook.Name
On Error Resume Next
MkDir ThisWorkbook.Path & "\Backups"
On Error GoTo 0
relativePath = ThisWorkbook.Path & "\Backups\" & ActiveWorkbook.Name
ActiveWorkbook.SaveCopyAs Filename:=relativePath & Format(Now, "d-mmm-yy hh-mm-ss")
'Dim NewClaims, CurrClaims, CurrNewClaims, PrevClaims, Rng, PrevClaimsLastRow, OrigRow As Range
'Dim FirstRow, LastRow, iX As Integer
Dim NewClaims As Range, _
CurrClaims As Range, _
CurrNewClaims As Range, _
PrevClaims As Range, _
Rng As Range, _
PrevClaimsLastRow As Range, _
OrigRow As Range, _
ToClear As Range
Dim FirstRow As Long, _
LastRow As Long, _
iX As Long
'turn screen updating off
Application.ScreenUpdating = False
'Filter new claims
Sheets("New Claims").Select
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$5000").AutoFilter Field:=1, Criteria1:="anoctua"
'insert new column to accomodate for old DWC
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Move New Claims to Current Claims
Set NewClaims = ActiveSheet.Range("A2", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
Range("A2:AE5000" & LastRow).Copy 'Trebor76 - not sure about this. I suspose it works because 'LastRow' at this stage is zero??
Sheets("Current Claims").Activate
'remove data validation (work-around to enable macro to work on Excel 2003)
Columns("AG:AH").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
If Cells(2, 1) <> "" Then
Set CurrClaims = ActiveSheet.Range("A2", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
Else: Set CurrClaims = Cells(2, 1)
End If
FirstRow = CurrClaims.Row
LastRow = CurrClaims(CurrClaims.Count).Row
Cells(LastRow, 1).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Re-set data validation
Range("AG:AG").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Y,N"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Columns("AH:AH").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Save, Likely Save, Breached"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Clear New Claims tab
Sheets("New Claims").Select
Selection.AutoFilter
Set NewClaims = ActiveSheet.Range("A2", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
LastRow = NewClaims(NewClaims.Count).Row
Set ToClear = ActiveSheet.Range("A2:AE" & LastRow)
ToClear.ClearContents
'Delete Column I from New Claims Tab
Columns("I:I").Select
Selection.Delete Shift:=xlToLeft
Columns("A:AE").Locked = False
Columns("AF:AH").Locked = True
' Find duplicates and clear
Sheets("Current Claims").Activate
'Set the CurrNewClaims variable to include all the current plus new claims
Set CurrNewClaims = ActiveSheet.Range("E1", ActiveSheet.Range("E" & Rows.Count).End(xlUp))
For iX = CurrNewClaims.Rows.Count To 2 Step -1
If WorksheetFunction.CountIf(CurrNewClaims, Cells(iX, 5).Value) > 1 Then
'update the new claim with the user entered values from the old
Set OrigRow = CurrNewClaims.Find(Cells(iX, 5).Value, LookIn:=xlValues, lookat:=xlWhole)
Range("AG" & iX & ":AI" & iX).Value = Range("AG" & OrigRow.Row & ":AI" & OrigRow.Row).Value
Range("I" & iX).Value = Range("H" & OrigRow.Row).Value
'delete "old" claims
Rows(OrigRow.Row).ClearContents
End If
Next
CurrNewClaims.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'delete old claims and move to old claims tab
Set CurrClaims = ActiveSheet.Range("A2", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
CurrClaims.EntireRow.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Old Claims").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'add date to existing selection
Selection.EntireRow.Columns("AJ").Value = Date
'Remove duplicated claims and update with recent data
Set CurrNewClaims = ActiveSheet.Range("E1", ActiveSheet.Range("E" & Rows.Count).End(xlUp))
For iX = CurrNewClaims.Rows.Count To 2 Step -1
If WorksheetFunction.CountIf(CurrNewClaims, Cells(iX, 5).Value) > 1 Then
Set OrigRow = CurrNewClaims.Find(Cells(iX, 5).Value, LookIn:=xlValues, lookat:=xlWhole)
Rows(OrigRow.Row).ClearContents
End If
Next
'delete all blank rows
Set NewClaims = ActiveSheet.Range("A2", ActiveSheet.Range("A" & Rows.Count).End(xlUp))
FirstRow = NewClaims.Row
LastRow = NewClaims(NewClaims.Count).Row
On Error Resume Next
NewClaims.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Selection.EntireRow.ClearContents
'sort by DWC at closure and move back to "current claims" tab
ActiveWorkbook.Worksheets("Old Claims").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Old Claims").AutoFilter.Sort.SortFields.Add Key:=Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Old Claims").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Current Claims").Activate
'delete all blank rows from "current claims" tab
Set CurrClaims = ActiveSheet.Range("E1", ActiveSheet.Range("E" & Rows.Count).End(xlUp))
Selection.ClearContents
CurrClaims.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Range("AG2:AG5000").ClearContents
'sort remaining claims in ascending order by current DWC
Cells.Select
ActiveWorkbook.Worksheets("Current Claims").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Current Claims").Sort.SortFields.Add Key:=Range( _
"H2:H844"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Current Claims").Sort
.SetRange Range("A1:AI844")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'come back to current claims tab
Sheets("Current Claims").Activate
'turn screen updating on
Application.ScreenUpdating = True
End Sub
Regards,
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks