Solved

Rewrite script for copy and paste data

Posted on 2011-03-15
11
176 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

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
 

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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

739 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