0

閉じたブックからデータを取得する次の Excel VBA コードがあります。マクロは機能してデータを取得しますが、私のデータ セットには 5 つの異なるアカウントのデータが 1 つのファイルにまとめられています。その特定のアカウントのデータを取得できる唯一の方法は、その特定のアカウントに正しい行数のデータを配置することですが、データセットからカウントする必要があり、自動化の目的を達成できません。

以下のコードに動的カウント関数の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

私のソースデータ。口座番号は列 A にあり、P 15001 で始まる 5 つの異なる口座があります。各口座には独自のテンプレートがあります。この場合、アカウント 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) は保持されます ---- 削除しようとしましたが、コードが問題を引き起こしているようです。

  • すべての「アカウント」シートに空の行が 1 つあります。

于 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 に答える