CODEWITHSUNDEEP
vbaexcel
AriKari
AriKari

Reputation: 323

Search and return function

I am very new to VBA and I need some help:

So I have two sheets Sh1 and Sh2 Sh1 has data in two columns "A" and "B" In Sh1 "A" it contains duplicate data but for the same data in "A" there is different data in "B" in the same sheet

Now the next sheet Sh2 the column "A" has unique records of column "A" of Sh1

Now initial condition is as follows:

In Sh1:

Column A    ColumnB
Ajh           Kjh
Bjh           Mjh
Cjh           Fjh
Ajh           Ljh
Djh           pok
Bjh           JKHKB
.
.
.
.
till row 379722

& in Sheet Sh2 the Column A has unique records of Column A of Sh1 Like this:

Sh2
Column A
Ajh
Bjh
Cjh
Djh
.
.

Now what I want is simple vba code for getting following output

Sh2

Column A   Column B   Column C  .............
Ajh          Kjh         Ljh     ..More data if Sh1 has more values for Ajh  
Bjh          Mjh         JKHKB  ...More data if Sh1 has more values for Bjh
Cjh          Fjh         .........More data if Sh1 has more values for Cjh
Djh          pok           .......More data if Sh1 has more values for Djh
.
.
.
and so on.

I have written the following code but it doesn't works:

Sub send()
 Dim val As String
 Dim nval As String
 Dim i As Long
 Dim j As Long
 Dim ran As Range

  Sheets("test1").Select
    For i = 2 To 5699
    val = Sheets("test1").Cells("i, 1").value
    Sheets("Sheet2").Select
       For j = 2 To 379722
         nval = Sheets("Sheet2").Cells("j, 1").value
         If nval = val Then
              Sheets("Sheet2").Cells("j, 2").Copy
              Sheets("test1").Select
              ActiveSheet.Paste
        End If
      Next j
   Next i
End Sub

Upvotes: 1

Views: 90

Answers (1)

Tim Williams
Tim Williams

Reputation: 166181

EDIT: much faster version

'faster
Sub send2()

    Dim arrSrc, shtDest As Worksheet, r As Long
    Dim arrDest
    Dim m, lr As Long, vr As Long, tmp
    Dim k, t

    Dim dictRows, dictCounts
    'dictionary to map "key" values to row numbers
    Set dictRows = CreateObject("scripting.dictionary")
    'dictionary to track counts of "key" values
    Set dictCounts = CreateObject("scripting.dictionary")

    t = Timer

    'pick all of the source data into an array for faster processing
    With Sheets("Sheet2")
        arrSrc = .Range(.Range("A1"), _
                        .Cells(Rows.Count, 1).End(xlUp)).Resize(, 2).Value
    End With

    lr = 1
    'capture unique values and counts from first column
    For r = 1 To UBound(arrSrc, 1)
        tmp = arrSrc(r, 1)
        'new value - add to dictRows and assign a row number
        If Not dictRows.exists(tmp) Then
            dictRows.Add tmp, lr
            lr = lr + 1
        End If
        'increment the count for this value
        dictCounts(tmp) = dictCounts(tmp) + 1
    Next r

    m = 0 'Find the required "width" of the destination array
          '  = the max count for any of the unique values
    For Each k In dictRows
       If dictCounts(k) > m Then m = dictCounts(k)
       dictCounts(k) = 2 'reset the counts to 2
    Next k

    'resize the destination array
    ReDim arrDest(1 To dictRows.Count, 1 To m + 1)

    'fill the first column of the dstination array
    For Each k In dictRows
       arrDest(dictRows(k), 1) = k
    Next k

    'fill rest of the destination array
    For r = 1 To UBound(arrSrc, 1)
        tmp = arrSrc(r, 1)
        arrDest(dictRows(tmp), dictCounts(tmp)) = arrSrc(r, 2)
        dictCounts(tmp) = dictCounts(tmp) + 1
    Next r

    'drop the array on the sheet
    Sheets("sheet2").Range("D1").Resize(dictRows.Count, m + 1).Value = arrDest

    Debug.Print Timer - t
End Sub

This will do what you want: you can begin with an empty destination sheet.

Sub send()

    Dim arrSrc, shtDest As Worksheet, r As Long
    Dim m, lr As Long, vr As Long, tmp

    Set shtDest = Sheets("test1")

    'current last row on destination sheet
    lr = shtDest.Cells(Rows.Count, 1).End(xlUp).Row

    'pick all of the source data into an array for faster processing
    With Sheets("Sheet2")
        arrSrc = .Range(.Range("A2"), _
                        .Cells(Rows.Count, 1).End(xlUp)).Resize(, 2).Value
    End With

    'loop over the array
    For r = 1 To UBound(arrSrc, 1)
        tmp = arrSrc(r, 1)
        If Len(tmp) > 0 Then
            'find the ColA value in the destination sheet
            m = Application.Match(tmp, shtDest.Columns(1), 0)
            If Not IsError(m) Then
                vr = m 'found it - get the row
            Else
                'value not on destination sheet: add it
                lr = lr + 1
                shtDest.Cells(lr, 1) = arrSrc(r, 1)
                vr = lr 'get the row
            End If

            'add the ColB value to the first empty cell on the located row
            shtDest.Cells(vr, Columns.Count).End( _
                    xlToLeft).Offset(0, 1).Value = arrSrc(r, 2)
        End If
    Next r

End Sub

Upvotes: 2

Related Questions