Solved

Rewrite script for copy and paste data

Posted on 2011-03-15
11
169 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
ID: 35144744
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
ID: 35144779
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
ID: 35145982
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
ID: 35183220
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
ID: 35183981
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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 

Author Comment

by:Cartillo
ID: 35185162
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
ID: 35185882
change nJ and nI to Long instead of Integer, will help with that overflow error.
0
 

Author Comment

by:Cartillo
ID: 35191385
Hi JoeNuvo,

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

Expert Comment

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

Author Comment

by:Cartillo
ID: 35233212
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
ID: 35298546
Hi Long/ssaqibh/JoeNuvo,

Thanks a lot for the great help.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Drop Down List with Unique/Distinct Values (enhancing the Combo-Box with a few steps and a little code) David miller (dlmille) Intro Have you ever created a data validation list from a database field or spreadsheet column (e.g., Zip Codes or Co…
Drop Down List with Unique/Distinct Values (Part II - ComboBox or ListBox and Data Validation List Bonus!) David Miller (dlmille) Intro This article focuses on delivering unique, sorted lists to list objects (e.g., ComboBox, ListBox) and Dat…
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …

932 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

13 Experts available now in Live!

Get 1:1 Help Now