Rewrite script for copy and paste data

Hi Experts,

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 String
Dim strTmp1 As String
'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 = 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 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(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 i
End With

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

Dim nNextRow As Long

nNextRow = NextAvailableRow

With 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 With
End With
End Sub

Open in new window

MatchedData.xls
CartilloAsked:
Who is Participating?
 
longtruongConnect With a Mentor Commented:
Hello Cartillo,

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.

Best Regards,

Long
MatchedData---Rewrite-Script.xls
0
 
Saqib Husain, SyedEngineerCommented:
Try this
Sub CopyData()
Dim strTmp As String
Dim strTmp1 As String
'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 = 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 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 = 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 i
End With

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

Dim nNextRow As Long

nNextRow = NextAvailableRow

With 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 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
 
JoeNuvoCommented:
Correct me if I'm wrong

current code, will perform check of each data from Sheet1, with the first 5 character of Type from Sheet2

and now, you want new code to able to check data from Sheet1 with Number column as well?
0
Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

 
CartilloAuthor Commented:
Hi Long/ssaqibh,

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.
0
 
Saqib Husain, SyedConnect With a Mentor EngineerCommented:
I have further modified the code to populate data without a blank column between sets of columns
Sub CopyData()
Dim strTmp As String
Dim strTmp1 As String
'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 = 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 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 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 i
End With

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

Dim nNextRow As Long

nNextRow = NextAvailableRow

With 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 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


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

Saqib
0
 
CartilloAuthor Commented:
Hi Saqib,


Shows error at this line

"For nJ = 1 To Range("TABLEDATA").Columns(nI).Rows.Count"

as "overflow". Please assist.
0
 
JoeNuvoCommented:
change nJ and nI to Long instead of Integer, will help with that overflow error.
0
 
CartilloAuthor Commented:
Hi JoeNuvo,

Tested, the macro continuously running without any result.
0
 
Saqib Husain, SyedEngineerCommented:
Did you test it with the file in the question?
0
 
CartilloAuthor Commented:
Hi ssaqibh/JoeNuvo/Long,

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
0
 
CartilloAuthor Commented:
Hi Long/ssaqibh/JoeNuvo,

Thanks a lot for the great 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.

All Courses

From novice to tech pro — start learning today.