VBA归档arrays和创build列

我需要编写一个可以捕获两个数组中现有列表的子表单，然后为花费在至less500美元的客户创build两个新的客户名称和金额数组。 在这些新的数组被填充之后，我必须将它们写入D和E列。

因此，第一列是从A3：A50这个客户的名字，第二列是从C3：50和客户购买的销售价格。

我无法编写通过数组sorting的代码部分，并决定销售价格是否大于$ 500。 有人能指出我哪里出错了吗？

这是我迄今为止，但它不起作用：

Sub ProductSales() ' These are inputs: the number of customers, the customer's name, ' and the dollar amount of each sale. Dim nCustomers As Integer Dim namesData() As String Dim dollarsData() As Integer ' The following are outputs: the customer name found over 500, and the number 'of customer over 500 Dim customerFound() As String Dim customerCount() As Integer ' Variables used in finding if sale is over 500 Dim isOver As Boolean Dim nFound As Integer ' Counters. Dim i As Integer Dim j As Integer ' Clear any old results in columns E to G. With wsData.Range("E2") Range(.Offset(1, 0), .Offset(0, 2).End(xlDown)).ClearContents End With ' Find number of customers in the data set, redimension the namesdata and ' dollarsData arrays, and fill them with the data in columns A and C. With wsData.Range("A2") nCustomers = Range(.Offset(1, 0), .End(xlDown)).Rows.Count ReDim namesData(1 To nCustomers) ReDim dollarsData(1 To nCustomers) For i = 1 To nCustomers namesData(i) = .Offset(i, 0).Value dollarsData(i) = .Offset(i, 2).Value Next End With ' Initialize the number of names found to 0. nFound = 0 ' Loop through all sales. For i = 1 To nCustomers ' Set the Boolean isOver to False, and change it to True only ' if the sale is over 500 isOver = False If nFound > 0 Then ' Loop through all customer names already found and add to new list ' and exit loop For j = 1 To nFound If dollarsData(i) > 500 Then isOver = True customerCount(j) = customerCount(j) + 1 Exit For End If Next End If If isOver Then ' The current product code is a new one, so update the list of ' codes found so far, and initialize the transactionsCount and dollarsTotal ' values for this new product. nFound = nFound + 1 ReDim Preserve customerFound(1 To nFound) ReDim Preserve customerCount(1 To nFound) customerCount(nFound) = namesData(i) customerCount(nFound) = 1 End If Next ' Place the results in columns E to G. For j = 1 To nFound With wsData.Range("E2") .Offset(j, 0).Value = customerFound(j) .Offset(j, 1).Value = customerCount(j) End With Next 

结束小组

Answer 1

Excel VBA具有将Range写入一行的function。 这是非常快速的，并保存开发人员不得不像你所做的那样写自己的迭代代码。 数组被声明为Variant ，语法是：

 readArray = Range("A3:A50").Value2 

这同样适用于将数组写入表单。 语法是：

  Range("A3:A50").Value = writeArray 

所以在你的项目的这一部分，你只需要阅读两栏。 循环遍历它们以find您的目标项目，然后填充您的输出数组。 你确实需要维度输出数组，所以在这个例子中，我使用了一个Collection来存储find的项目的每个索引，大小只是Collection.Count 。

下面的示例硬编码范围维度，但它应该给你一个如何简化你自己的代码的想法：

 Dim ws As Worksheet Dim namesData As Variant Dim dollarsData As Variant Dim output() As Variant Dim foundIndexes As Collection Dim i As Long Dim v As Variant 'Set the worksheet object Set ws = ThisWorkbook.Worksheets("Sheet1") 'change to your sheet name 'Read the data With ws.Range("A3:A50") namesData = .Value2 dollarsData = .Offset(, 2).Value2 End With 'Find the target customers Set foundIndexes = New Collection For i = 1 To UBound(dollarsData, 1) If dollarsData(i, 1) > 500 Then foundIndexes.Add i End If Next 'Size the output array ReDim output(1 To foundIndexes.Count, 1 To 2) 'Populate the output array i = 1 For Each v In foundIndexes output(i, 1) = namesData(v, 1) output(i, 2) = dollarsData(v, 1) i = i + 1 Next 'Write array to sheet ws.Range("D3").Resize(UBound(output, 1), UBound(output, 2)).Value = output 

Answer 2

我不太确定你的实际目标是什么

但是你可以从这个开始

 Option Explicit Sub ProductSales() Dim nCustomers As Integer ' inputs: the number of customers Dim namesData As Variant, dollarsData As Variant 'inputs: the customer's name, and the dollar amount of each sale Dim customerFound As Variant, customerDollarsFound As Variant 'ouputs: the customer name found over 500, and their corresponding dollars Dim firstValueIndex As Long ' index for the first dollar value > 500 in sorted column, if any With Worksheets("wsData") .Range("E3:G" & .Cells(.Rows.Count, "E").End(xlUp).Row).ClearContents '<~~ clear previous results With .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ consider column A values down to its last non empty cell .Resize(, 3).Sort key1:=.Cells(1, 3), Order1:=xlDescending, Header:=xlYes '<~~ sort it by dollar amount in ascending order With .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ consider column A form range A2 to down to its last non empty cell, which could be now different since sort has shifted blank cells to the range end namesData = Application.Transpose(.Value) '<~~ fill first array dollarsData = Application.Transpose(.Offset(, 2).Value) '<~~fill 2nd array If GetFirstIndex(.Offset(, 2).Cells, 501, firstValueIndex) Then '<~~ if there's any value > 500 in column "C" (ie two columns right of "A") ... customerFound = Application.Transpose(.Resize(firstValueIndex).Value) '<~~ ... then fill first output array... customerDollarsFound = Application.Transpose(.Resize(firstValueIndex).Offset(, 2).Value) '<~~ ... and second output array End If End With End With If firstValueIndex > 0 Then '<~~ if output arrays have values... .Range("E3").Resize(firstValueIndex).Value = Application.Transpose(customerFound) '<~~ ... then fill output range for names... .Range("F3").Resize(firstValueIndex).Value = Application.Transpose(customerDollarsFound) '<~~ and fill output range for dollars End If End With End Sub Function GetFirstIndex(rng As Range, minVal As Double, firstIndex As Long) As Boolean On Error Resume Next firstIndex = WorksheetFunction.Match(minVal, rng, -1) GetFirstIndex = firstIndex > 0 End Function