Need Help with automation.

Hello all,
My job involves comparing data every fortnight. I receive the report in a text file. Some members could be omitted and new members could be added. The unique EID in is given to each member.

I was doing this with MS Access 2003. Recently we had new hardware upgrade and MS Office 2010 was installed without MS Access 2010. Though I can do a lot with MS Access, I am a novice with MS Excel.

For example,

Pay day 23MAR17

EID Surname GivenName  Pay <<< Heading
14123 Prabhu Raghu $2,721.00
14124 Jain Sanjay $2,727.00
14125 O’Connell Greg $2,222.00
14126 Nitiskas John $3,425.00
14127 Sawant Bhanu $2,263.00
14128 Evans Craig $2,440.00
14129 Sawant Vim $2,721.00
Pay Day 06APR14

EID Surname GivenName  Pay <<< Heading
14123 Prabhu Raghu $2,821.00
14124 Jain Sanjay $2,727.00
14125 O’Connell Greg $2,222.00
14127 Sawant Bhanu $2,263.00
14128 Evans Craig $2,440.00
14129 Prabhu Vim $2,721.00
14130 Kamath Sunil $2,222.00

14126 Nitiskas John $3,425.00 has dropped out from previous fortnight
14130 Kamath Sunil $2,222.00 has been added in the current fortnight

Comparing

14123 Prabhu Raghu $2,721.00
14123 Prabhu Raghu $2,821.00 Had a pay rise

14129 Sawant Vim $2,721.00
14129 Prabhu Vim $2,721.00 Had a surname change

I have 5 worksheets in the workbook. They are named “PreviousFN”, “CurrentFN”,”OmittedMembers”, “NewMembers” and “ChangedMembers”
I need some help with automating this. Any ideas would be welcome.

Each fortnight there would be 6000+ records.

100-200 members drop out

100-200 new members are added

800-999 members have change.

I format the data and pass it on to other members for processing.

Regards

Raghu

Expert Asked on April 13, 2017 in VBA.
Add Comment
1 Answer(s)

I have sorted the above problem. Code is given below…

Sub seperate()
Call CleanSheets
MsgBox "1 of 10 Cleaning sheets done!"
Call CreateHeadings
MsgBox "2 of 10 Create Headings done!"
Call DumpDeleted
MsgBox "3 of 10 Dumped deleted members done!"
Call DumpAdded
MsgBox "4 of 10 Dumped new members done!"
Call DumpCommonFromPrevious
MsgBox "5 of 10 Dumped common from previous members done!"
Call DumpCommonFromCurrent
MsgBox "6 of 10 Dumped common from current members done!"
Call SortMatched
MsgBox "7 of 10 Sorting done!"
Call InsertBlankRows
MsgBox "8 of 10 insert blank rows done!"
Call prepareToDelete
MsgBox "9 of 10 Comparing lines done!"
Call DeleteRows
MsgBox "10 of 10 Deleting common rows done!"
Range("A1").Select
ActiveWorkbook.Save
End Sub
Sub CleanSheets()
Sheets("Deleted").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Added").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Matched").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
End Sub
Sub CreateHeadings()
Sheets("Deleted").Select
ActiveCell.FormulaR1C1 = "EID"
Range("B1").Select
ActiveCell.FormulaR1C1 = "NAME"
Range("C1").Select
ActiveCell.FormulaR1C1 = "PAY"
Range("D1").Select
ActiveCell.FormulaR1C1 = "PayDay"
Range("A1:D1").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
Sheets("Added").Select
ActiveCell.FormulaR1C1 = "EID"
Range("B1").Select
ActiveCell.FormulaR1C1 = "NAME"
Range("C1").Select
ActiveCell.FormulaR1C1 = "PAY"
Range("D1").Select
ActiveCell.FormulaR1C1 = "PayDay"
Range("A1:D1").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
Sheets("Matched").Select
ActiveCell.FormulaR1C1 = "EID"
Range("B1").Select
ActiveCell.FormulaR1C1 = "NAME"
Range("C1").Select
ActiveCell.FormulaR1C1 = "PAY"
Range("D1").Select
ActiveCell.FormulaR1C1 = "PayDay"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Product"
Range("A1:E1").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1").Select
End Sub
Sub DumpDeleted()
Sheets("Previous").Select
Range("A2").Select
Do While ActiveCell.Value <> ""
If Application.WorksheetFunction.CountIf(Sheets("Current").Range("A:A"), ActiveCell.Value) = 0 Then
Range(ActiveCell.Row & ":" & ActiveCell.Row).Copy Sheets("Deleted").Range("A10000").End(xlUp).Offset(1, 0)
End If
ActiveCell.Offset(1, 0).Select
Loop
Sheets("Deleted").Select
Columns("A:D").Select
Selection.Columns.AutoFit
Range("A1").Select
End Sub
Sub DumpAdded()
Sheets("Current").Select
Range("A2").Select
Do While ActiveCell.Value <> ""
If Application.WorksheetFunction.CountIf(Sheets("Previous").Range("A:A"), ActiveCell.Value) = 0 Then
Range(ActiveCell.Row & ":" & ActiveCell.Row).Copy Sheets("Added").Range("A10000").End(xlUp).Offset(1, 0)
End If
ActiveCell.Offset(1, 0).Select
Loop
Sheets("Added").Select
Columns("A:D").Select
Selection.Columns.AutoFit
Range("A1").Select
End Sub
Sub DumpCommonFromPrevious()
Sheets("Previous").Select
Range("A2").Select
Do While ActiveCell.Value <> ""
If Application.WorksheetFunction.CountIf(Sheets("Current").Range("A:A"), ActiveCell.Value) <> 0 Then
Range(ActiveCell.Row & ":" & ActiveCell.Row).Copy Sheets("Matched").Range("A10000").End(xlUp).Offset(1, 0)
End If
ActiveCell.Offset(1, 0).Select
Loop
Sheets("Matched").Select
Columns("A:D").Select
Selection.Columns.AutoFit
Range("A1").Select
End Sub
Sub DumpCommonFromCurrent()
Sheets("Current").Select
Range("A2").Select
Do While ActiveCell.Value <> ""
If Application.WorksheetFunction.CountIf(Sheets("Previous").Range("A:A"), ActiveCell.Value) <> 0 Then
Range(ActiveCell.Row & ":" & ActiveCell.Row).Copy Sheets("Matched").Range("A10000").End(xlUp).Offset(1, 0)
End If
ActiveCell.Offset(1, 0).Select
Loop
Sheets("Matched").Select
Columns("A:D").Select
Selection.Columns.AutoFit
Range("A1").Select
End Sub
Sub SortMatched()
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Matched").Select
Cells.Select
ActiveWorkbook.Worksheets("Matched").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Matched").Sort.SortFields.Add Key:=Range("A2:A" & lRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Matched").Sort.SortFields.Add Key:=Range("D2:D" & lRow) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Matched").Sort
.SetRange Range("A1:E" & lRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:E").Select
Selection.Columns.AutoFit
Range("A1").Select
End Sub
Sub InsertBlankRows()
Dim intStartRow As Integer
Dim intLastRow As Integer
Dim iCntr As Integer
intStartRow = 4 'Since the Row 1 have headers
intLastRow = Sheets("Matched").Cells(Sheets("Matched").Rows.Count, "A").End(xlUp).Row - 1
For iCntr = intLastRow To intStartRow Step -2
Rows(iCntr).EntireRow.Insert
Next
End Sub
Sub prepareToDelete()
Dim intStartRow As Integer
Dim intLastRow As Integer
Dim iCntr As Integer
intStartRow = 4 'Since the Row 1 have headers
intLastRow = Sheets("Matched").Cells(Sheets("Matched").Rows.Count, "A").End(xlUp).Row + 1
For iCntr = intLastRow To intStartRow Step -3
Range("B" & iCntr).Select
ActiveCell.FormulaR1C1 = "=R[-1]C=R[-2]C"
Range("B" & iCntr).Select
ActiveCell.FormulaR1C1 = "=(R[-1]C=R[-2]C)*1"
Range("B" & iCntr).Select
Selection.AutoFill Destination:=Range("B" & iCntr & ":" & "C" & iCntr), Type:=xlFillCopy
Range("B" & iCntr & ":" & "C" & iCntr).Select
Range("E" & iCntr).Select
ActiveCell.FormulaR1C1 = "=PRODUCT(RC[-3]:RC[-2])"
Next
End Sub
Sub DeleteRows()
Dim i As Integer
Dim FirstRow As Integer
Dim LastRow As Integer
FirstRow = 2
Sheets("Matched").Select
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = LastRow To FirstRow Step -1
If Cells(i, 5) = 0 Then
Rows(i).Delete Shift:=xlUp
ElseIf Cells(i, 5) = 1 Then
Rows(i - 2 & ":" & i).Delete Shift:=xlUp
End If
i = i - 2
Next i
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub
Function GetLastRow() As Integer
Dim i As Integer
Range("A1").Select
i = 1
Do
Selection.Offset(1, 0).Select
i = i + 1
If Selection.Value = "" Then
GetLastRow = i
End If
Loop
End Function

The workbook has 5 worksheets named “Previous”, “Current”, “Deleted”,”Added” and “Matched”

 

The data in “Previous” is

EID NAME PAY PayDay
14123 Joe1 $1,234.00 29-Jun-17
14124 Joe2 $1,235.00 29-Jun-17
14125 Joe3 $1,236.00 29-Jun-17
14126 Joe4 $1,237.00 29-Jun-17
14127 Joe5 $1,238.00 29-Jun-17
14128 Joe6 $1,239.00 29-Jun-17
14129 Joe7 $1,240.00 29-Jun-17
14130 Joe8 $1,241.00 29-Jun-17
14131 Joe9 $1,242.00 29-Jun-17
14132 Joe10 $1,243.00 29-Jun-17
14133 Joe11 $1,244.00 29-Jun-17
14134 Joe12 $1,245.00 29-Jun-17
14135 Joe13 $1,246.00 29-Jun-17

and in “Current” is

EID NAME PAY PayDay
14123 Joe11 $1,234.00 13-Jul-17
14124 Joe2 $1,222.00 13-Jul-17
14125 Joe3 $1,236.00 13-Jul-17
14127 Joe5 $3,333.00 13-Jul-17
14128 Joe66 $1,239.00 13-Jul-17
14129 Joe7 $4,444.00 13-Jul-17
14130 Joe8 $1,241.00 13-Jul-17
14131 Joe99 $5,555.00 13-Jul-17
14134 Joe12 $1,245.00 13-Jul-17
14135 Joe13 $6,666.00 13-Jul-17
14136 Joe14 $1,247.00 13-Jul-17
14137 Joe15 $7,777.00 13-Jul-17
14138 Joe16 $1,249.00 13-Jul-17
14139 Joe17 $8,888.00 13-Jul-17
14140 Joe18 $1,251.00 13-Jul-17

 

Please feel free to modify the code….

 

Regards

 

Raghu

 

 

Expert Answered on August 8, 2017.
Add Comment
  • Found this useful?

    Please share using the share button above.

    If you found the answer is best answer for your question, Please mark as 'best answer' by clicking on the right tick mark icon at the left side of the answer.

    Found the answer useful and wants to credit the user, then vote the answer (vote up).

  • Your Answer

    By posting your answer, you agree to the privacy policy and terms of service.