搜索和返回功能

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