search和返回function
我对VBA很新，我需要一些帮助：
所以我有两张表Sh1和Sh2 Sh1有两列“A”和“B”的数据在Sh1“A”它包含重复的数据，但是对于相同的数据在“A”有不同的数据在“B”在相同片
现在下一张表格Sh2的列“A”具有Sh1的列“A”的唯一logging
现在初始条件如下：
在Sh1：
Column A ColumnB Ajh Kjh Bjh Mjh Cjh Fjh Ajh Ljh Djh pok Bjh JKHKB . . . . till row 379722 ＆在Sheet Sh2中，A列有Sh1列A的唯一logging像这样：
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
编辑：更快的版本
'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