I would like to request Experts to modify the attached. Currently the script crosschecked first 5 alphabets from sheet 2 (all data under “Type” column) with sheet1. If the data matched, the matched data will copied at “Matched” sheet. I’ve copied few sample “Type” data at column A for Experts to get better view on how the “CopyData” function.

Now I would like to crosschecked all data under “Number” columns (Sheet2) with data at Sheet 1. If the data matched, the matched data need to copied at “Matched” sheet (Type and Number). I have copied sample data for Experts at “Matched” sheet for Experts perusal. Hope Experts could help me to modify the code.

Sub CopyData()Dim strTmp As StringDim strTmp1 As String'Build the data dictionaryDim oDicTmp As ObjectSet oDicTmp = CreateObject("Scripting.Dictionary")Dim nI As IntegerDim nJ As Integer For nI = 1 To Range("TABLEDATA").Columns.Count For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count strTmp = Trim(Range("TABLEDATA").Columns(nI).Rows(nJ).Value) If strTmp <> "" Then If Not (oDicTmp.Exists(strTmp)) Then oDicTmp.Add 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 fixedWith Sheets("Sheet2") On Error Resume Next .Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete Shift:=xlToLeft On Error GoTo 0 vIn = .Range("A1").CurrentRegion.ValueEnd WithReDim 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(vIn(i, j)) & vIn(i, j + 1) strTmp1 = Left(vIn(i, j + 1), 5) If Not .Exists(strTmp) And oDicTmp.Exists(strTmp1) Then n = n + 1 vOut(n, 1) = vIn(i, j) vOut(n, 2) = vIn(i, j + 1) .Add strTmp, 1 End If Next j Next iEnd Withp = WorksheetFunction.RoundUp(n / nCol, 0)Dim nNextRow As LongnNextRow = NextAvailableRowWith Sheets("Matched") 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 If n = 0 Then MsgBox "The number of rows is 0. The result is empty." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error" Exit Sub Else .Offset(1).Resize(n, 3) = vOut End If 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 WithEnd WithEnd Sub

Sub CopyData()Dim strTmp As StringDim strTmp1 As String'Build the data dictionaryDim oDicTmp As ObjectSet oDicTmp = CreateObject("Scripting.Dictionary")Dim nI As IntegerDim nJ As Integer For nI = 1 To Range("TABLEDATA").Columns.Count For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count strTmp = Trim(Range("TABLEDATA").Columns(nI).Rows(nJ).Value) If strTmp <> "" Then If Not (oDicTmp.Exists(strTmp)) Then oDicTmp.Add 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 fixedWith Sheets("Sheet2") On Error Resume Next .Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete Shift:=xlToLeft On Error GoTo 0 vIn = .Range("A1").CurrentRegion.ValueEnd WithReDim 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 = 2 To UBound(vIn, 2) - 1 Step 2 strTmp = Trim(vIn(i, j)) & vIn(i, j + 1) strTmp1 = vIn(i, j + 1) If Not .Exists(strTmp) And oDicTmp.Exists(strTmp1) Then n = n + 1 vOut(n, 1) = vIn(i, j) vOut(n, 2) = vIn(i, j + 1) .Add strTmp, 1 End If Next j Next iEnd Withp = WorksheetFunction.RoundUp(n / nCol, 0)Dim nNextRow As LongnNextRow = NextAvailableRowWith Sheets("Matched") 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 If n = 0 Then MsgBox "The number of rows is 0. The result is empty." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error" Exit Sub Else .Offset(1).Resize(n, 3) = vOut End If 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 WithEnd WithEnd SubFunction NextAvailableRow()Dim nResult As LongDim 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 nRNextAvailableRow = 1End Function

I have changed your attached code a bit and would like post it here for you to review. Please help review the attached file and let me know if it is good.

Please keep in mind that whenever you want to change the data in Sheet 1, please remember to change the TABLEDATA name to cover all data as well.

Sorry for the late respond. Thanks a lot for the solution.

ssaqibh: Need to maintained the data sequence, "Number" data need to display first followed by "Type" data. The suggested code extract Type followed by Number.

Long: Is that any chance to remove the blank row in between data "Number" and "Type"? also named the range at sheet 1 as "TABLEDATA" automatically whenever I copied with new data. Currently I manually update this range, few time I totally forgot about this rules and end up with wrong result. Hope this is possible.

I have further modified the code to populate data without a blank column between sets of columns

Sub CopyData()Dim strTmp As StringDim strTmp1 As String'Build the data dictionaryDim oDicTmp As ObjectSet oDicTmp = CreateObject("Scripting.Dictionary")Dim nI As IntegerDim nJ As Integer For nI = 1 To Range("TABLEDATA").Columns.Count For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count strTmp = Trim(Range("TABLEDATA").Columns(nI).Rows(nJ).Value) If strTmp <> "" Then If Not (oDicTmp.Exists(strTmp)) Then oDicTmp.Add 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 fixedWith Sheets("Sheet2") On Error Resume Next .Rows(2).SpecialCells(xlCellTypeBlanks).EntireColumn.Delete Shift:=xlToLeft On Error GoTo 0 vIn = .Range("A1").CurrentRegion.ValueEnd WithReDim vOut(1 To UBound(vIn, 1) * UBound(vIn, 2), 1 To 2)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(vIn(i, j)) & vIn(i, j + 1) strTmp1 = Left(vIn(i, j + 1), 5) If Not .Exists(strTmp) And oDicTmp.Exists(strTmp1) Then n = n + 1 vOut(n, 1) = vIn(i, j) vOut(n, 2) = vIn(i, j + 1) .Add strTmp, 1 End If Next j Next iEnd Withp = WorksheetFunction.RoundUp(n / nCol, 0)Dim nNextRow As LongnNextRow = NextAvailableRowWith Sheets("Matched") With .Range("A" & Trim(Str(nNextRow))) If nNextRow = 1 Then .Resize(, 2).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 If n = 0 Then MsgBox "The number of rows is 0. The result is empty." & vbCrLf & vbCrLf & "The process is how halted.", vbCritical + vbOKOnly, "Error" Exit Sub Else .Offset(1).Resize(n, 3) = vOut End If End If For j = 1 To nCol - 1 If nNextRow = 1 Then .Offset(, j * 2).Resize(, 2).Value = Array("Number", "Type", "") End If .Offset(p + 1, (j - 1) * 2).Resize(n - (p * j), 2).Cut .Offset(1, j * 2) Next j End WithEnd WithEnd SubFunction NextAvailableRow()Dim nResult As LongDim 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 nRNextAvailableRow = 1End Function

Furthermore you can paste the following code in the code pane for the sheet1 which will update the range name whenever you change the input data.

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveWorkbook.Names.Add Name:="TABLEDATA", RefersTo:=Range(Range("A2").End(xlDown), Range("A2").End(xlToRight))
End Sub

Apology for the late respond. I have tested with the actual data, but its not giving any result. I have attached the workbook for your perusal. Sorry for the inconvenience caused. Test-Number.zip

This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.

After seeing numerous questions for Dynamic Data Validation I notice that most have used Visual Basic to solve the problem. This suggestion is purely formula based and can be used in multiple rows.