0

我有以下 Excel VBA 代码从关闭的工作簿中提取数据。宏工作并提取数据，但我的数据集将五个不同帐户的数据合并到一个文件中。我可以为该特定帐户提取数据的唯一方法是，如果我为该特定帐户放置正确数量的数据行，但我必须从我的数据集中计算它，这超出了自动化的目的。

我想在下面的代码中放一个动态计数函数vba代码。

假设我想提取帐户“P 87848”的所有行数据。

Const NumRows& = 250

在 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

我的源数据。Account Number 在 A 列，它有 5 个不同的帐户，以 P 15001 开头。每个帐户都有自己的模板。在这种情况下，我只想提取帐户 P 15001 的数据。列是不变的，但行会发生变化。

帐号 证券 ID 数量 成本 当地市场价格 市场价值 当地

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
4

2 回答 2

1

以下代码会将目标工作簿中的所有数据值复制到当前工作簿，并在目标工作簿列 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

缺点：

  • 原始工作表（Sheet1，Sheet2，Sheet3）将被保留----我试图删除它们，但代码似乎会造成麻烦；

  • 每个“帐户”表上都会有一个空行。

于 2012-08-28T04:42:06.297 回答
0

复制所有可能不是最好的主意，只需要解决类似的任务，在我的情况下，它有超过 1000000 行和大约 56 张纸，所以复制都需要时间。

我确实使用与您的示例相同的方法来读取值，但具有验证规则，所以想法是检查您是否阅读以及是否需要它 - 保存到字符串数组，如果不跳过它 - 最好的结果是表格按验证属性排序。子代码：

...
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 
...

在此之后，您将获得一堆字符串，其中包含与验证字符串相关的所需数据。然后，您可以将其保存到数组中，例如： strValArray = Split(strValString, ",") 并在需要时将其粘贴到工作表中。

于 2016-04-08T13:00:28.560 回答