Question

enter image description here

你好，我正在做一个宏，它复制列VALUES1，VALUES2，VALUES3上的值，如果它不是空白的，那么当ARTICLE是相同的时候。

我会有第一个电子表格，我希望宏返回第二个电子表格。

我已经设法如何制作它：

Sub test()

Dim i, last, j, x As Integer
Dim R As Range

last = Sheets("List2").Range("A100000").End(xlUp).Row - 2

For i = 0 To last

    Set R = Sheets("List2").Range("A2")

        If Not WorksheetFunction.CountIf(Sheets("List2").Columns(1), _
        Sheets("List2").Range("A2").Offset(i, 0).Value) = 0 Then

            For j = 1 To WorksheetFunction.CountIf(Sheets("List2").Columns(1), _

                Sheets("List2").Range("A2").Offset(i, 0).Value)
                Set R = Sheets("List2").Columns(1).Find(Sheets("List2").Range("A2"). _
                Offset(i, 0).Value, R, LookAt:=xlWhole)

                    For x = 0 To 2

                        If Not Sheets("List2").Range("B2").Offset(i, x).Value = "" Then

                            R.Offset(0, "1" + x).Value = Sheets("List2"). _ 
                            Range("B2").Offset(i, x).Value

                        End If
                    Next x
            Next j
        End If
Next i

End Sub

但问题花了太长时间，因为我有大约10.000行和20列，除了电子表格不合适，所以它可能有一个混乱，像（A，B，B，A ，...）

有没有办法让它更快更好???

非常感谢。 Themolestones。

Answer 1

这是一个非常简单的解决方案，可以解决您的问题：

Sheet2!A1=Sheet1!A1
Sheet2!B1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!B:B)

Sheet2!C1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!C:C)
Sheet2!D1=SUMIF(Sheet1!$A:$A,Sheet2!$A1,Sheet1!D:D)

将这些公式放在=左侧的单元格中并向下复制。你真的只需要前两个，因为你也可以将第二个复制到右边。

您需要按文章对Sheet1进行排序。

就是这样。

当然，有时可能需要使用VBA实现此功能。通常使用VBA处理大量单元格的最快方法是使用范围的数组副本。使用工作表函数并循环遍历单个单元格引用可以减慢您的速度。

编辑：

这将是我的VBA解决方案

Public Sub Demo()
  Dim arrRange() As Variant
  Dim arrRangeResult() As Variant
  Dim i As Long
  Dim j As Long
  Dim copyVal As Variant
  Dim copyCond As Variant
  Dim copyCol As Long

  'create two copies of the origin data
  arrRange = Range("A:D")
  arrRangeResult = Range("A:D")

  'loop through first data-copy, downwards through the articles
  For i = LBound(arrRange, 1) + 1 To UBound(arrRange, 1)
    'stop loop, if no article was found
    If arrRange(i, 1) = "" Then Exit For
    'store current article ID
    copyCond = arrRange(i, 1)
    'loop sideways through value-columns
    For j = LBound(arrRange, 2) + 1 To UBound(arrRange, 2)
      'store value & column, when found
      If arrRange(i, j) <> "" Then
        copyVal = arrRange(i, j)
        copyCol = j
        Exit For
      End If
    Next j

    'loop through output array and paste value
    For j = LBound(arrRangeResult, 1) + 1 To UBound(arrRangeResult, 1)
      If arrRangeResult(j, 1) = copyCond Then
        'paste-down found value to all occurences of article
        arrRangeResult(j, copyCol) = copyVal
      ElseIf arrRangeResult(j, 1) = "" Then
        'early stop, when no article ID is found
        Exit For
      End If
    Next j
  Next i

  'create output
  Range("K:N") = arrRangeResult
End Sub

更快速地查找和复制值

1 个答案: