Excel VBA 计算已关闭工作簿中特定条件的行数
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/12135710/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA Count rows for a certain criteria in closed workbook
提问by cemg
I have the following Excel VBA code to pull data from a closed workbook. The macro works and pulls the data, but my data set has data for five different accounts consolidated into one file. The only way I can pull the data for that one specific account is if I put the correct number of rows of data for that specific account but I would have to count it from my data set which it beats the purpose from automating it.
我有以下 Excel VBA 代码可以从关闭的工作簿中提取数据。宏工作并提取数据，但我的数据集将五个不同帐户的数据合并到一个文件中。我可以为该特定帐户提取数据的唯一方法是，如果我为该特定帐户放置了正确数量的数据行，但我必须从我的数据集中计算它，这超出了自动化的目的。
I want to put a dynamic count function vba code in the following code below.
我想在下面的代码中放置一个动态计数函数vba代码。
Lets say I want to pull all the row data for account "P 87848".
假设我想提取帐户“P 87848”的所有行数据。
Const NumRows& = 250
What would be the best way to insert or implement a count function in the Const NumRow&
在 Const NumRow& 中插入或实现计数函数的最佳方法是什么？
Sub GetDataDemo()
Dim FilePath$, Row&, Column&, Address$
Dim path As String
'change constants & FilePath below to suit
'***************************************
Const FileName$ = "DNAV.xlsx"
Const SheetName$ = "DNAV"
Const NumRows& = 250
Const NumColumns& = 15
path = "C:\Documents\Marenco\VBA\"
'***************************************
DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
For Row = 1 To NumRows
For Column = 1 To NumColumns
Address = Cells(Row, Column).Address
Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
Columns.AutoFit
Next Column
Next Row
ActiveWindow.DisplayZeros = False
End Sub
Private Function GetData(path, File, Sheet, Address)
Dim Data$
Data = "'" & path & "[" & File & "]" & Sheet & "'!" & _
Range(Address).Range("A1").Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function
My Source Data. Account Number is in Column A, and it has 5 different account starting with P 15001. Each account has its own template. In this case I want to pull the data for account P 15001 only. The Column are constant, but the rows changes.
我的源数据。帐号在 A 列，它有 5 个不同的帐户，以 P 15001 开头。每个帐户都有自己的模板。在这种情况下，我只想提取帐户 P 15001 的数据。列是不变的，但行会发生变化。
Account Number Security ID Quantity Cost Local Market Price Market Value Local
帐号 证券编号 数量 成本 当地市场价格 市场价值 当地
P 15001 AUD 276,250.00 276,250.00 1.00 276,250.00
P 15001 B5790J3 4,000,000.00 4,086,200.00 110.60 4,424,080.00
P 15001 B3XF8Z3 5,000,000.00 5,239,900.00 109.98 5,498,750.00
P 15001 B50VKT6 5,000,000.00 5,134,250.00 103.37 5,168,300.00
P 15001 CCTAUD 615,000.00 615,000.00 0.96 615,000.00
P 15001 B3XQ210 6,900,000.00 7,090,440.00 101.82 7,025,511.00
P 15001 B55HXF6 4,300,000.00 4,522,844.40 105.50 4,536,543.00
P 15001 B4PM5Y7 2,900,000.00 3,145,730.42 112.29 3,256,381.00
P 15001 CCTCAD 2,530,000.00 2,530,000.00 0.99 2,530,000.00
P 15001 EUR 82,921.26 82,921.26 1.00 82,921.26
P 15001 B5VVFK1 5,600,000.00 5,992,648.00 106.60 5,969,415.20
P 15001 B10S9K3 7,270,000.00 8,794,985.99 124.58 9,056,960.88
P 15001 B4XF7K8 10,530,000.00 12,079,614.58 118.06 12,431,696.94
P 15001 B5V3C06 14,500,000.00 14,511,620.00 100.44 14,564,467.00
P 15001 B54VTS4 35,150,000.00 35,922,019.50 104.24 36,640,535.75
P 15001 B6YXBD6 3,580,000.00 3,719,341.36 109.04 3,903,753.72
P 15001 B40Z1F4 2,530,000.00 2,814,675.60 111.38 2,817,797.62
P 15001 B63GF45 6,150,000.00 7,170,378.00 117.56 7,229,884.65
P 15001 B04FJB4 34,850,000.00 38,186,084.50 108.91 37,956,668.40
P 15001 B45JHF3 9,200,000.00 9,935,736.49 105.81 9,734,547.60
P 15001 B28VPL4 970,000.00 1,113,787.27 114.05 1,106,277.14
回答by Passerby
The following code will copy all data valuesfrom the target workbook to current workbook, sheet-separated by "accounts" in target workbook column A.
以下代码将目标工作簿中的所有数据值复制到当前工作簿中，在目标工作簿 A 列中由“帐户”分隔。
Sub getdata()
Dim rows As Integer
Dim cols As Integer
Dim row As Integer
Dim col As Integer
Dim crow As Integer
Dim acc As String
DoEvents
Application.ScreenUpdating = False
On Error Resume Next
Workbooks.Open Filename:="demo.xls"
ThisWorkbook.Activate
If Err.Number <> 0 Then
Application.ScreenUpdating = True
MsgBox "File does not exist"
Exit Sub
End If
rows = Workbooks("demo.xls").Sheets(1).Range("A65536").End(xlUp).row
cols = Workbooks("demo.xls").Sheets(1).Range("IV1").End(xlToLeft).Column
For row = 1 To rows
acc = Workbooks("demo.xls").Sheets(1).Cells(row, 1).Value
If acc <> "" Then
On Error Resume Next
ThisWorkbook.Sheets(acc).Activate
If Err.Number <> 0 Then
ThisWorkbook.Sheets.Add().Name = acc
End If
crow = ThisWorkbook.Sheets(acc).Range("A65536").End(xlUp).row + 1
For col = 2 To cols
ThisWorkbook.Sheets(acc).Cells(crow, col - 1).Value = Workbooks("demo.xls").Sheets(1).Cells(row, col).Value
Next
End If
Next
'optional:
'ThisWorkbook.SaveAs Filename:="YYYYMMDD.xls"
Application.ScreenUpdating = True
End Sub
Downsides:
缺点：
Original sheets (Sheet1, Sheet2, Sheet3) will be preserved ---- I tried to delete them, but the code seems to cause trouble;
There will be one empty row on every "account" sheet.
原来的工作表（Sheet1、Sheet2、Sheet3）会被保留----我试图删除它们，但代码似乎有问题；
每个“帐户”表上都会有一个空行。
回答by Gorodeckij Dimitrij
Copy all maybe not the best idea, just have to solve similar task, in my case its over 1000000 rows and about 56 sheets so copy all take time.
全部复制可能不是最好的主意，只需要解决类似的任务，就我而言，它有超过 1000000 行和大约 56 张纸，所以复制都需要时间。
That i do I use same method to read values as in you example but have validation rule, so idea is to check that you read and if its that you need - save to string array, if not skip it - best result is then table is sorted by validation attribute. Sub code:
我使用与您示例中相同的方法来读取值，但具有验证规则，所以想法是检查您是否阅读以及是否需要 - 保存到字符串数组，如果不跳过它 - 最好的结果是表按验证属性排序。子代码：
...
i = 2 'skiping hedears
flag = True 'flag to know then we need jump out of cicle
ScrMode = Application.ScreenUpdating 'save curent status
DoEvents 'allow others subs to do stuff
Application.ScreenUpdating = False
Do While flag
Address = Cells(i, ColNumber).Address 'there is colnumber where is validation value is stored, i - row count
strRetVal = GetData(DataFileName, SheetName, Address) 'get result
If strRetVal <> "0" Then 'check if cell is empty (to know that its end of data column) in you case additional check required if returned result is = "P 15001"
If strValString = "" Then
strValString = strRetVal
Else
strValString = strValString & "," & strRetVal 'I am adding value there to long string, you may need to use few of them to collect all values you need, so one string variable per column
End If
i = i + 1
Else
flag = False
End If
Loop
Application.ScreenUpdating = ScrMode 'restoring mode
...
after this you will got bunch of strings with needed data that is related to validation string. Then you can save it to array like: strValArray = Split(strValString, ",") and past it to sheet if needed.
在此之后，您将获得一堆字符串，其中包含与验证字符串相关的所需数据。然后您可以将其保存到数组中，如： strValArray = Split(strValString, ",") 并在需要时将其粘贴到工作表中。
