Solved

Rewrite script for copy and paste data

Posted on 2011-03-15
11
167 Views
Last Modified: 2012-05-11
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
0
Comment
Question by:Cartillo
  • 5
  • 3
  • 2
  • +1
11 Comments
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
Comment Utility
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
 
LVL 11

Expert Comment

by:JoeNuvo
Comment Utility
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
 
LVL 3

Accepted Solution

by:
longtruong earned 400 total points
Comment Utility
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
 

Author Comment

by:Cartillo
Comment Utility
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
 
LVL 43

Assisted Solution

by:Saqib Husain, Syed
Saqib Husain, Syed earned 100 total points
Comment Utility
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
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:Cartillo
Comment Utility
Hi Saqib,


Shows error at this line

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

as "overflow". Please assist.
0
 
LVL 11

Expert Comment

by:JoeNuvo
Comment Utility
change nJ and nI to Long instead of Integer, will help with that overflow error.
0
 

Author Comment

by:Cartillo
Comment Utility
Hi JoeNuvo,

Tested, the macro continuously running without any result.
0
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
Comment Utility
Did you test it with the file in the question?
0
 

Author Comment

by:Cartillo
Comment Utility
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
 

Author Closing Comment

by:Cartillo
Comment Utility
Hi Long/ssaqibh/JoeNuvo,

Thanks a lot for the great help.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now