Copy matched data

1) Is data in sheet 1 unique?
2) Is type and number in sheet 2 unique?
3) What will you do with duplicated data?
3) Is it ok to reduce the number of columns to 2 all sheets?

Hi Roy,

Sorry for the confusion. we need to crosscheck first 5 latter from columns "Type" at sheet2. If the data is matched with sheet 1 then we need to copy the whole data from sheet 2 (number + type) to Matched sheet. E.g. crosscheck data "ATZDI" (sheet1), 4 data are found at sheet2:

571479      ATZDI01HS11A
571479      ATZDI01HS11B
572599      ATZDI01HS11B
573150      ATZDI01HS11A

And, the data need to copy at Matched sheet.

All data at sheet1 are unique, but data at sheet 2 not so. Some time we do have same "Number" but with different "Type" Data. The reason we have more rows at Matched sheet is, I'm having humungous data that need to cross checked.

Hope I've answered your Q.  

ok try this

Sub test()
Dim i As Integer
Dim j As Integer
Dim m As Integer
Dim id_end_row As Integer
Dim id_str As String
Dim type_str As String
Dim type_str2 As String
m = 2

Worksheets("sheet1").Activate
Range("A65536").Select
Selection.End(xlUp).Select
id_end_row = ActiveCell.Row

Worksheets("sheet2").Activate
Range("B65536").Select
Selection.End(xlUp).Select
type_end_row = ActiveCell.Row

    For i = 2 To id_end_row
        'id_str = Worksheets("sheet1").Cells(i, 1).Value
        id_str = Worksheets("Sheet1").Range("A" & i & "").Value
            
        For j = 2 To type_end_row
            type_str = Worksheets("Sheet2").Range("B" & j & "").Value
            type_str2 = Left(type_str, 5)

            If id_str = type_str2 Then
            Sheets("sheet2").Select
            Range("A" & j & ":" & " B" & j & "").Select
            'Range("A2:B2").Select
            Selection.Copy
            Sheets("Matched").Select
            Range("A" & m & "").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            m = m + 1
            Else
            End If
        Next j
    Next i
End Sub

Select allOpen in new window

The code only check the 1st column of the sheet 1 and first 2 column in the sheet 2. it will copy the matched data and paste it in "matched".

You will need to reduce the column for this code to work.
Please double check and let me know if there is any error

DataCheck-fixed.xls

Hi Roy,

Thanks for the code. The reason I need more columns at sheet 2 and Matched is because I'm having more than 1 millions data that need to crosscheck. Is that possible to fix with 10 columns at Matched sheet, but at sheet 2 I need to maintain the columns from A:AH. One more think, I have another code, which is using "Dictionary Script", created by Experts Yong, but the problem with this script is, its not copying the right data. Perhaps you can test this code. Attached the code for your reference.    

Sub CopyData()
'Build the data dictionary
Dim oDicTmp As Object
Set oDicTmp = CreateObject("Scripting.Dictionary")

Dim nI As Integer
Dim nJ As Integer

    For nI = 1 To Range("TABLEDATA").Columns.Count
        For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count
            strTmp = Range("TABLEDATA").Columns(nI).Rows(nJ).Value
            If strTmp <> "" Then
                If Not (oDicTmp.Exists(strTmp)) Then
                    oDicTmp.Add strTmp, 1
                'Else
                '    oDicTmp.Item(strTmp) = oDicTmp.Item(strTmp) + 1
                End If
            End If
        Next nJ
    Next nI
 
'------------------------------
Dim oDic As Object, vOut(), vIn(), i As Long, j As Long, n As Long, p As Long, nCol As Long

'nCol = Application.InputBox("How many sets of columns for the results (each set has three columns)?", Type:=1)
nCol = 6 'The number of columns is fixed

With Sheets("Sheet2")
    On Error Resume Next
    .Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete shift:=xlToLeft
    On Error GoTo 0
    vIn = .Range("A1").CurrentRegion.Value
End With

ReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 3)

Set oDic = CreateObject("Scripting.Dictionary")

With oDic
    For i = 2 To UBound(vIn, 1)
        For j = 1 To UBound(vIn, 2) - 1 Step 2
            'strTmp = Trim(Str(vIn(i, j))) & Left(vIn(i, j + 1), 5)
            'strTmp = Left(vIn(i, j + 1), 5)
            'strTmp = vIn(i, j + 1)
            strTmp = Trim(Str(vIn(i, j))) & vIn(i, j + 1)
            If Not .Exists(strTmp) Then  'Long modified
                n = n + 1
                vOut(n, 1) = vIn(i, j)
                'vOut(n, 2) = strTmp 'Left(vIn(i, j + 1), 5)
                'vOut(n, 2) = Left(vIn(i, j + 1), 5)
                vOut(n, 2) = vIn(i, j + 1)
                .Add strTmp, 1
            End If
        Next j
    Next i
End With

p = WorksheetFunction.RoundUp(n / nCol, 0)

Dim nNextRow As Long

nNextRow = NextAvailableRow

With Sheets("Matched")
    '.UsedRange.Clear
    'With .Range("A1")
    With .Range("A" & Trim(Str(nNextRow)))
    
        If nNextRow = 1 Then
            .Resize(, 3).Value = Array("Number", "Type", "")
        End If
        
        'Long added one if statement to check if the number of rows exceed 65536 rows
        If n > 65536 Then
            MsgBox "The number of rows is " & Trim(Str(n)) & " which exceeds 65536." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error"
            Exit Sub
        Else
            .Offset(1).Resize(n, 3) = vOut
        End If
        
        For j = 1 To nCol - 1
            If nNextRow = 1 Then
                .Offset(, j * 3).Resize(, 3).Value = Array("Number", "Type", "")
            End If
            .Offset(p + 1, (j - 1) * 3).Resize(n - (p * j), 3).Cut .Offset(1, j * 3)
        Next j
    End With
End With

End Sub

Function NextAvailableRow()

Dim nResult As Long
Dim nR As Long

    For nR = 1 To 65535
        If Cells(nR, 1).Value = "" Then
            If nR > 1 Then
                NextAvailableRow = nR - 1
            Else
                NextAvailableRow = nR
            End If
            Exit Function
        End If
    Next nR

NextAvailableRow = 1

End Function

Select allOpen in new window

Hi Roy,

You can ignore the attached code if the method is not your kind.

sorry, today is my busy day.
If you convert the worksheet from excel 2003 to excel 2007. you would get over 1 milion rows
I will look at your code when I have a chance.

Convert to excel 2007
==
Click on the icon in the upper left corner of your worbook.
Click on Excel Options
Click on Save
Under Save Files in this Format, change to Excel Workbook (*.xlsx)
Click OK.
==

Hi,

Thanks a lot for the help