自動分析不對稱欄位的匯總功能

yuch8663

附件裡的檔案，是一位高手所寫的，可以將網頁下載的財務報表自動分析所屬年度依每家公司的順序
自動排列，但是他用的方法是讓每個新增項目的起始位置自動空出三列，可是我因為要用套公式做計算
如果公司家數有變動，公式的參照位址就會失效，
請問有人會將程式碼改成每個新增項目的起始位置是指定的嗎?這樣在做複製公式時就不會有參造錯誤的問題了，謝謝 !

mineshine

你只要改一行代碼的參數就可以了

    stock_offset = 3    ' 每一個比較項目之間，要空出幾列列距？

改成
    stock_offset = 0    ' 每一個比較項目之間，要空出幾列列距？
那就不會有空行

yuch8663

樓上大大不好意思，你可能誤會我的意思，因為我只會寫固定的相對參照方式
例如
有7家公司，間距暫定為3
那M3公式設為  b3+b15-b27  ，然後複製到m4 : m9都ok
可是再重新篩選10家公司則上述的公式會參照錯誤，
又要重新修改公式為b3+b18-b33，這樣會很麻煩
因此我需要給每一個項目間的間距必須是固定列數。

mineshine

我加了一段程式，你看看可以嗎?

yuch8663

謝謝mineshine大大的幫助，可是我想要的不是這樣，我需要的是讓每一個項目列出的儲存格位置是固定的起始位置，然後我才能套用公式列出每個年度或每一季的數據，用來匯出圖表顯示每一年度或每一季的變化，目前mineshine大大的程式碼好像只是將所有項目的值直接運算，這樣我就無法產生圖表了。可以再修改嗎?謝謝。

mineshine

我實在是不懂，你可以提供一個完整的例子嗎?

yuch8663

mineshine 大大請參考，附件檔內有說明，謝謝。

mineshine

原帖由 yuch8663 于 2009-5-28 23:17 发表
mineshine 大大請參考，附件檔內有說明，謝謝。

yuch8663

謝謝mineshine 大大可這迴圈很深奧，看不太懂意思，可以說明如何運用這組程序碼嗎?

mineshine

Sub SumTest()
    Dim account_item_name(4), p(4), i, j, n, S

    account_item_name(1) = "現金及約當現金"
    account_item_name(2) = "流動資產"
    account_item_name(3) = "利息收入"
    account_item_name(4) = "投資收入／股利收入"

    For j = 1 To 4
        For i = 1 To [A65536].End(xlUp).Row / 2
            If Cells(i, 1) = account_item_name(j) And Cells(i + 1, 1) = "年" Then p(j) = i 'account_item_name(j)四個Title的起始列
        Next i
    Next j
    Range("A" & p(1) + 1 & ":" & Chr(64 + [A2].End(xlToRight).Column) & p(1) + 1).Copy  '複製第2列年度
    ActiveSheet.Paste Destination:=Cells(p(1) + 1, [A2].End(xlToRight).Column + 4)      '貼到年度後的第四欄
    Range("A" & p(1) + 2 & ":A" & p(2) - 3).Copy                                        '複製第1欄股票名稱
    ActiveSheet.Paste Destination:=Cells(p(1) + 2, [A2].End(xlToRight).Column + 4)      '貼到年度後的第四欄
   
    For j = p(1) + 2 To p(2) - 4        '從"現金及約當現金"下列到"流動資產"前4列
        For i = 2 To 10                 'B欄到J欄
            With Range("A" & p(1) & ":A" & p(4) - 1)    '查詢範圍"現金及約當現金"-"投資收入／股利收入"前一列
                Set c = .Find(Cells(j, 1), LookIn:=xlValues, Lookat:=xlWhole)   '依股票名稱查詢
                If Not c Is Nothing Then
                    firstAdd = c.Address
                    Do
                        n = n + 1   '查找account_item_name(1)-account_item_name(3)三個部分裡的股票名稱
                        If n < 3 Then S = S + Cells(c.Row, i)       'b3+b15
                        If n = 3 Then
                            Cells(j, i + 13) = S - Cells(c.Row, i)  'b3+b15-b27
                            n = 0: S = 0
                            Exit Do
                        End If
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAdd
                End If
            End With
        Next i
    Next j
End Sub