Question

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

所以我有两张Sh1和Sh2 Sh1在两列中有数据＆＃34; A＆＃34;和＆＃34; B＆＃34; 在Sh1＆＃34; A＆＃34;它包含重复的数据但对于＆＃34; A＆＃34;中的相同数据;在＆＃34; B＆＃34;中有不同的数据。在同一张表中

现在下一张纸Sh2列＃34; A＆＃34; 列具有唯一的记录＆＃34; A＆＃34; Sh1

现在初始条件如下：

在Sh1：

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

＆安培;在Sheet Sh2中，A列具有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

搜索和返回功能

1 个答案: