Поиск и возврат функции

Question

Я новичок в VBA, и мне нужна помощь:

Так у меня есть два листа Ш1 и Ш2 Ш1 имеет данные в двух столбцах «A» и «B» В Sh1 «А "содержит повторяющиеся данные но для одних и тех же данных в„а“есть различные данные в„B“в том же листе

Теперь следующий лист Ш2 столбец„а“ имеет уникальные записи столбца„A“ от Sh1

Теперь начальное состояние выглядит следующим образом:

В Sh1:

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

& в лист Ш2 колонна А имеет уникальные записи Колонка А Sh1 Как это:

Sh2 
Column A 
Ajh 
Bjh 
Cjh 
Djh 
. 
. 

Теперь то, что я хочу, это просто VBA код для получения следующих выход

Ш2

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. 

Я написал следующий код, но он не работает:

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 

Answer 1

EDIT: гораздо быстрее, версия

'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 

Это будет делать то, что вы хотите, вы можете начать с пустым местом назначения лист.

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