Macro to check and clean double data entry??

**CharlieGough** · 05-24-2012, 03:50 PM

Hi, I hope someone can help me on here... I work for an NGO in Africa collecting fish catch data and the data is entered by various people. to avoid errors we have been doing double data entry but checking for errors using simple IF-Functions and conditional formatting in excel is particularly time consuming as it involves constantly switching between worksheets. What I need is a quick and effective method of checking, verifying data and producing a clean data sheet.

So to outline the data

I have two worksheets data1 and data2 (upto 20 columns and possibly thousands of rows) both data is the same but has been entered by two different people. In a third worksheet I want to have checked and cleaned data. What I am looking for is if it was possible for a macro or similar to run through the two worksheets and where data is the same paste it directly into data3 BUT (this is where it gets tricky and far beyond my level of understanding of VBA) throw up a message box that gives the person checking the data three options ...
option 1 the value in data1 is true
option2 the value in data2 is true or
option 3 neither 1 or 2 is true and new value is recorded.
The option chosen would then be entered into data3.

I have uploaded an example of the kind of data I am looking at - where data3 currently reads ERROR would be where I need the macro to provide the checker with a choice box?

I have read a number of threads in search of the answer but none of them yet seem to give me what I want!I have every faith in the people on this network to be able to help me with this problem

Fingers crossed and thanks to anyone who can assist!

**StevenM** · 05-24-2012, 05:08 PM

This is not exactly what you asked for, but it is a simple piece of code.
Think of it as a suggestion.

Run: CompareData1And2
If there is a difference between data1 and data2, it colors those cells red.
Setup a split screen and it should be easy enough to go through both worksheets and make the corrections.
After you have made your corrections, run it again. If the correction were made, it will clear the red cells of color.

Sub CompareData1And2()
    Dim rgData1 As Range, rgData2 As Range, nRow As Long, nCol As Long

    Set rgData1 = Worksheets("Data1").UsedRange
    Set rgData2 = Worksheets("Data2").UsedRange
    
    For nRow = 2 To rgData1.Rows.Count
        For nCol = 2 To rgData1.Columns.Count
            If rgData1.Cells(nRow, nCol) <> rgData2.Cells(nRow, nCol) Then
                rgData1.Cells(nRow, nCol).Interior.Color = 255
                rgData2.Cells(nRow, nCol).Interior.Color = 255
            Else
                If rgData1.Cells(nRow, nCol).Interior.Color = 255 Then
                    rgData1.Cells(nRow, nCol).Interior.ColorIndex = xlNone
                End If
                If rgData2.Cells(nRow, nCol).Interior.Color = 255 Then
                    rgData2.Cells(nRow, nCol).Interior.ColorIndex = xlNone
                End If
            End If
        Next nCol
    Next nRow
End Sub

**Pichingualas** · 05-24-2012, 05:49 PM

Try with this:

Sub CheckAndCleanData()
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
    Dim Ws3 As Worksheet
    Dim Col1 As Long
    Dim Col2 As Long
    Dim Col3 As Long
    Dim Row3 As Long
    Dim HeaderText As String
    Dim LastRow As Long
    Dim Answer As Byte
    
    Set Ws1 = Sheets("Data1")
    Set Ws2 = Sheets("Data2")
    Set Ws3 = Sheets("Data3")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    LastRow = WorksheetFunction.Max(Ws1.Cells.SpecialCells(xlCellTypeLastCell).Row, Ws2.Cells.SpecialCells(xlCellTypeLastCell).Row)
    
    For Col3 = 1 To Ws3.Cells(1, Ws3.Columns.Count).End(xlToLeft).Column
        HeaderText = Ws3.Cells(1, Col3).Value
        
        If HeaderText = "" Then GoTo NextHeader
        
        For Col1 = 1 To Ws1.Cells(1, Ws1.Columns.Count).End(xlToLeft).Column
            If Ws1.Cells(1, Col1).Value = HeaderText Then Exit For
        Next Col1
        
        For Col2 = 1 To Ws2.Cells(1, Ws2.Columns.Count).End(xlToLeft).Column
            If Ws2.Cells(1, Col2).Value = HeaderText Then Exit For
        Next Col2
        
        If Col1 > Ws1.Cells(1, Ws1.Columns.Count).End(xlToLeft).Column _
            Or Col2 > Ws2.Cells(1, Ws2.Columns.Count).End(xlToLeft).Column _
        Then GoTo NextHeader
        
        For Row3 = 2 To LastRow
            If Ws1.Cells(Row3, Col1).Value = "" And Ws2.Cells(Row3, Col2).Value = "" Then Exit For
            
            If Ws1.Cells(Row3, Col1).Value = Ws2.Cells(Row3, Col2).Value Then
                Ws3.Cells(Row3, Col3).Value = Ws1.Cells(Row3, Col1).Value
            Else
                Application.ScreenUpdating = True
                
                Answer = MsgBox("The values are different. To keep Data1 press yes, to keep Data2 press no, to enter new data press cancel. Data1 = " _
                & Ws1.Cells(Row3, Col1).Value & " Data2 = " & Ws2.Cells(Row3, Col2).Value, vbYesNoCancel, "Check and Clean data")
                
                If Answer = vbYes Then
                    Ws3.Cells(Row3, Col3).Value = Ws1.Cells(Row3, Col1).Value
                ElseIf Answer = vbNo Then
                    Ws3.Cells(Row3, Col3).Value = Ws2.Cells(Row3, Col2).Value
                Else
                    Ws3.Cells(Row3, Col3).Value = Application.InputBox("Enter new value", "Check and Clean Data")
                End If
                
                Application.ScreenUpdating = False
            End If
        Next Row3
NextHeader:
    Next Col3
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

I hope that helps, I think it works as you needed.

**Pichingualas** · 05-24-2012, 07:04 PM

Your sample workbook with the macro:

example_1.xlsm

**Fettertiger** · 05-25-2012, 04:22 AM

Hi Charlie,

even though the solutions which you already received assumingly worked, I thought I will share my solution too. It was readily developed when my battery gave up last night

- therfore I am only able to show it now.

The solution uses a Userform rather than Messageboxes, therfore I have included the macros into the attached workbook
ngo_fish.xlsm

Hope it does what you expected.

Regards

Theo

**CharlieGough** · 05-25-2012, 06:26 AM

Wow wow wow! Thank you so much! all three replies have been super useful and will be a fantastic time saver in checking our many many files of double entered data! I really can't thank you enough this is brilliant and it works great! Will definitely use this forum again

Thank you, Thank you and finally Thank you!