Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 209
  • Last Modified:

Copy matched data

Hi Experts,

I would like to request Experts help create a macro to copy and paste data from “Sheet2” into “Matched” sheet if the data at “Sheet1” (table 1 to table 2)  is matched. I have attached the sample data at Match sheet for Experts to get better view. Hope Experts will help me to create this feature.



DataCheck.xls
0
Cartillo
Asked:
Cartillo
  • 6
  • 4
1 Solution
 
royhsiaoCommented:
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?
0
 
CartilloAuthor Commented:
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.  
0
 
royhsiaoCommented:
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

Open in new window

0
Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

 
royhsiaoCommented:
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
0
 
royhsiaoCommented:
0
 
CartilloAuthor Commented:
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

Open in new window

0
 
CartilloAuthor Commented:
Hi Roy,

You can ignore the attached code if the method is not your kind.
0
 
royhsiaoCommented:
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.
==
0
 
royhsiaoCommented:
Try this code.
1) sheet 1: put all unique id in column A
2) sheet 2: make sure each column has same row
3) run the macro and check if it works
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
Dim type_col As Integer
Dim A As String
Dim B As String
Dim col_address As String
Dim col_address_less_1 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 type_col = 1 To 17
            For j = 2 To type_end_row
                type_str = Worksheets("Sheet2").Cells(j, type_col + type_col).Value
                type_str2 = Left(type_str, 5)
                A = Worksheets("Sheet2").Cells(j, type_col + type_col).Address
                B = Worksheets("Sheet2").Cells(j, type_col).Address
                
                If type_col + type_col < 26 Then
                col_address = Right(Left(A, 2), 1)
                col_address_less_1 = Right(Left(B, 2), 1)
                Else
                col_address = Right(Left(A, 3), 2)
                col_address_less_1 = Right(Left(B, 3), 2)
                End If
                
                    If id_str = type_str2 Then
                    Sheets("sheet2").Select
                    Range(col_address_less_1 & j & ":" & col_address & j).Select
                    Selection.Copy
                    Sheets("Matched").Select
                    Range(col_address_less_1 & m).Select
                    ActiveSheet.Paste
                    Application.CutCopyMode = False
                    m = m + 1
                    Else
                End If
            Next j
            m = 2
        Next type_col
    Next i
End Sub

Open in new window

0
 
CartilloAuthor Commented:
Hi,

Thanks a lot for the help
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 6
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now