搜索和返回功能

Question

我很新的VBA，我需要一些帮助：

所以，我有两片SH1和SH2 Sh1的有两列“A”和“B” 在Sh1的“数据“它包含了重复数据 ，但在相同的数据‘A’有不同的数据‘B’，在同一张纸上

现在，下表Sh2的列‘A’ 有列的唯一记录‘A’ Sh1

现在初始条件如下：

在Sh1的：

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

&在表Sh2的塔中有Sh1的 的A柱像这样独特的记录：

Sh2 
Column A 
Ajh 
Bjh 
Cjh 
Djh 
. 
. 

现在我想要的是获取以下简单的VBA代码输出

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. 

我写了下面的代码，但它不工作：

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

编辑：更快的版本

'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